PRCHHI0.m

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 ---PRCHHI0   1042     printed  Apr 09, 2024@21:12:05                                                                                                                                                                                                     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