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 Dec 13, 2024@02:07:45 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
