- 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 ---[H[J[2J[HPRCHHI1 1137 printed Feb 18, 2025@23:34:09 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