PRCHHI1.m

PRCHHI1 ;WISC/TGH-IFCAP SEGMENT HE ;12-18-92/08:38

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

HE(A,A1,A2,VAR1,CNTR,NUM) ;PO HEADER INFORMATION SEGMENT

 N A12,DA,I,NM,P,PHN,PNM,PPM,STRNG,TOR,X,Y

 S A12=$G(^PRC(442,VAR1,12))

 S X=$P(A1,U,15)

 D JD^PRCFDLN S PRCHPOD=$E(X,1,3)+1700_$E(Y,1,3)

 S X=$P(A,U,10)

 D JD^PRCFDLN S PRCHDD=$E(X,1,3)+1700_$E(Y,1,3),P=$P(A1,U,10)

 S X=$P(A12,U,2)

 S X=$$DECODE^PRCHES5(VAR1),PPM=X

 S NM=$P(^VA(200,P,0),U),PNM=$P(NM,",",2)_" "_$P(NM,",")

 S PPM=$E("ES/"_PPM,1,30)

 S PHN=$P($G(^VA(200,P,.13)),U,2)

 S PHN=$P(PHN,U)

 S TOR=$P(A,U,19),TOR=$S(TOR=2:"P",1:"U")

 S PRCHTP(1,CNTR+1)="S X=""|HE"";540"

 S PRCHTP(1,CNTR+2)="S X=PRCHPOD;541"

 S PRCHTP(1,CNTR+3)="S X=""01"";542"

 S PRCHTP(1,CNTR+4)="S X=PRCHDD;543"

 S PRCHLCNT=$P(A,U,14)

 S PRCHTP(1,CNTR+5)="S X=PRCHLCNT;520"

 S PRCHCOM=$P($G(^PRC(442,VAR1,4,0)),U,4)

 S:PRCHCOM="" PRCHCOM=0

 S PRCHTP(1,CNTR+6)="S X=PRCHCOM;546.1"

 S STRNG="HE"_"^^"_PRCHPOD_"^"_"01"_"^"_PRCHDD_"^^^^^^^"_PRCHLCNT_"^"_PRCHCOM_"^|"

 S NUM=NUM+1,^TMP($J,"STRING",NUM)=STRNG

 S CNTR=CNTR+6

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCHHI1   1137     printed  Apr 09, 2024@21:14:50                                                                                                                                                                                                     Page 2

PRCHHI1   ;WISC/TGH-IFCAP SEGMENT HE ;12-18-92/08:38

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

HE(A,A1,A2,VAR1,CNTR,NUM) ;PO HEADER INFORMATION SEGMENT

 +1        NEW A12,DA,I,NM,P,PHN,PNM,PPM,STRNG,TOR,X,Y

 +2        SET A12=$GET(^PRC(442,VAR1,12))

 +3        SET X=$PIECE(A1,U,15)

 +4        DO JD^PRCFDLN

           SET PRCHPOD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)

 +5        SET X=$PIECE(A,U,10)

 +6        DO JD^PRCFDLN

           SET PRCHDD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)

           SET P=$PIECE(A1,U,10)

 +7        SET X=$PIECE(A12,U,2)

 +8        SET X=$$DECODE^PRCHES5(VAR1)

           SET PPM=X

 +9        SET NM=$PIECE(^VA(200,P,0),U)

           SET PNM=$PIECE(NM,",",2)_" "_$PIECE(NM,",")

 +10       SET PPM=$EXTRACT("ES/"_PPM,1,30)

 +11       SET PHN=$PIECE($GET(^VA(200,P,.13)),U,2)

 +12       SET PHN=$PIECE(PHN,U)

 +13       SET TOR=$PIECE(A,U,19)

           SET TOR=$SELECT(TOR=2:"P",1:"U")

 +14       SET PRCHTP(1,CNTR+1)="S X=""|HE"";540"

 +15       SET PRCHTP(1,CNTR+2)="S X=PRCHPOD;541"

 +16       SET PRCHTP(1,CNTR+3)="S X=""01"";542"

 +17       SET PRCHTP(1,CNTR+4)="S X=PRCHDD;543"

 +18       SET PRCHLCNT=$PIECE(A,U,14)

 +19       SET PRCHTP(1,CNTR+5)="S X=PRCHLCNT;520"

 +20       SET PRCHCOM=$PIECE($GET(^PRC(442,VAR1,4,0)),U,4)

 +21       if PRCHCOM=""

               SET PRCHCOM=0

 +22       SET PRCHTP(1,CNTR+6)="S X=PRCHCOM;546.1"

 +23       SET STRNG="HE"_"^^"_PRCHPOD_"^"_"01"_"^"_PRCHDD_"^^^^^^^"_PRCHLCNT_"^"_PRCHCOM_"^|"

 +24       SET NUM=NUM+1

           SET ^TMP($JOB,"STRING",NUM)=STRNG

 +25       SET CNTR=CNTR+6

 +26       QUIT