| 1 | PRCHHI1 ;WISC/TGH-IFCAP SEGMENT HE ;12-18-92/08:38
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | HE(A,A1,A2,VAR1,CNTR,NUM) ;PO HEADER INFORMATION SEGMENT
|
|---|
| 5 | N A12,DA,I,NM,P,PHN,PNM,PPM,STRNG,TOR,X,Y
|
|---|
| 6 | S A12=$G(^PRC(442,VAR1,12))
|
|---|
| 7 | S X=$P(A1,U,15)
|
|---|
| 8 | D JD^PRCFDLN S PRCHPOD=$E(X,1,3)+1700_$E(Y,1,3)
|
|---|
| 9 | S X=$P(A,U,10)
|
|---|
| 10 | D JD^PRCFDLN S PRCHDD=$E(X,1,3)+1700_$E(Y,1,3),P=$P(A1,U,10)
|
|---|
| 11 | S X=$P(A12,U,2)
|
|---|
| 12 | S X=$$DECODE^PRCHES5(VAR1),PPM=X
|
|---|
| 13 | S NM=$P(^VA(200,P,0),U),PNM=$P(NM,",",2)_" "_$P(NM,",")
|
|---|
| 14 | S PPM=$E("ES/"_PPM,1,30)
|
|---|
| 15 | S PHN=$P($G(^VA(200,P,.13)),U,2)
|
|---|
| 16 | S PHN=$P(PHN,U)
|
|---|
| 17 | S TOR=$P(A,U,19),TOR=$S(TOR=2:"P",1:"U")
|
|---|
| 18 | S PRCHTP(1,CNTR+1)="S X=""|HE"";540"
|
|---|
| 19 | S PRCHTP(1,CNTR+2)="S X=PRCHPOD;541"
|
|---|
| 20 | S PRCHTP(1,CNTR+3)="S X=""01"";542"
|
|---|
| 21 | S PRCHTP(1,CNTR+4)="S X=PRCHDD;543"
|
|---|
| 22 | S PRCHLCNT=$P(A,U,14)
|
|---|
| 23 | S PRCHTP(1,CNTR+5)="S X=PRCHLCNT;520"
|
|---|
| 24 | S PRCHCOM=$P($G(^PRC(442,VAR1,4,0)),U,4)
|
|---|
| 25 | S:PRCHCOM="" PRCHCOM=0
|
|---|
| 26 | S PRCHTP(1,CNTR+6)="S X=PRCHCOM;546.1"
|
|---|
| 27 | S STRNG="HE"_"^^"_PRCHPOD_"^"_"01"_"^"_PRCHDD_"^^^^^^^"_PRCHLCNT_"^"_PRCHCOM_"^|"
|
|---|
| 28 | S NUM=NUM+1,^TMP($J,"STRING",NUM)=STRNG
|
|---|
| 29 | S CNTR=CNTR+6
|
|---|
| 30 | Q
|
|---|
