- PRCHHI0 ;WISC/TGH-IFCAP CONTROL STRING SEGMENT ;5/19/92 3:17 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- CNTL(A,A1,A2,CNTR) N B,I,JD,X,Y
- S PRCHA=A,PRCHTC=A2
- D NOW^%DTC S X=$P(%,".") D JD^PRCFDLN S PRCHJD=$E(X,1,3)+1700_$E(Y,1,3)
- S TIME=$P(%,".",2)_"000000",TIME=$E(TIME,1,6)
- S PRCHTP(1,CNTR+1)="S X=PRCHSYS;500"
- S PRCHTP(1,CNTR+2)="S X=+$P(PRCHA,U);1"
- S PRCHTP(1,CNTR+3)="S X=200;63"
- S PRCHTP(1,CNTR+4)="S X=PRCHTC;430"
- S PRCHTP(1,CNTR+5)="S X=PRCHJD;501"
- S PRCHTP(1,CNTR+6)="S X=TIME;502"
- S PRCHPON=$P($P(PRCHA,U),""-"")_$P($P(PRCHA,U),""-"",2)
- S PRCHPON=PRCHPON_" ",PRCHPON=$E(PRCHPON,1,11)
- S PRCHTP(1,CNTR+7)="S X=PRCHPON;503"
- S PRCHTP(1,CNTR+8)="S X=""001"";503.1"
- S PRCHTP(1,CNTR+9)="S X=""001"";503.2"
- S PRCHTP(1,CNTR+10)="S X=""001"";504"
- S CNTR=CNTR+10
- S PRCFA("STRING")=""
- S PRCFA("STRING")=PRCHSYS_"^"_+$P(PRCHA,U)_"^200^"_PRCHTC_"^"_PRCHJD_"^"_TIME_"^"_$P($P(PRCHA,U),"-")_$P($P(PRCHA,U),"-",2)_" "_"^001^001^040^|"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHHI0 1042 printed Feb 18, 2025@23:34:08 Page 2
- PRCHHI0 ;WISC/TGH-IFCAP CONTROL STRING SEGMENT ;5/19/92 3:17 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 QUIT
- CNTL(A,A1,A2,CNTR) NEW B,I,JD,X,Y
- +1 SET PRCHA=A
- SET PRCHTC=A2
- +2 DO NOW^%DTC
- SET X=$PIECE(%,".")
- DO JD^PRCFDLN
- SET PRCHJD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
- +3 SET TIME=$PIECE(%,".",2)_"000000"
- SET TIME=$EXTRACT(TIME,1,6)
- +4 SET PRCHTP(1,CNTR+1)="S X=PRCHSYS;500"
- +5 SET PRCHTP(1,CNTR+2)="S X=+$P(PRCHA,U);1"
- +6 SET PRCHTP(1,CNTR+3)="S X=200;63"
- +7 SET PRCHTP(1,CNTR+4)="S X=PRCHTC;430"
- +8 SET PRCHTP(1,CNTR+5)="S X=PRCHJD;501"
- +9 SET PRCHTP(1,CNTR+6)="S X=TIME;502"
- +10 SET PRCHPON=$PIECE($PIECE(PRCHA,U),""-"")_$PIECE($PIECE(PRCHA,U),""-"",2)
- +11 SET PRCHPON=PRCHPON_" "
- SET PRCHPON=$EXTRACT(PRCHPON,1,11)
- +12 SET PRCHTP(1,CNTR+7)="S X=PRCHPON;503"
- +13 SET PRCHTP(1,CNTR+8)="S X=""001"";503.1"
- +14 SET PRCHTP(1,CNTR+9)="S X=""001"";503.2"
- +15 SET PRCHTP(1,CNTR+10)="S X=""001"";504"
- +16 SET CNTR=CNTR+10
- +17 SET PRCFA("STRING")=""
- +18 SET PRCFA("STRING")=PRCHSYS_"^"_+$PIECE(PRCHA,U)_"^200^"_PRCHTC_"^"_PRCHJD_"^"_TIME_"^"_$PIECE($PIECE(PRCHA,U),"-")_$PIECE($PIECE(PRCHA,U),"-",2)_" "_"^001^001^040^|"
- +19 QUIT