| 1 | PRCHHI8 ;WISC/TGH-IFCAP SEGMENT DH ;10/2/92 4:08 PM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | DH(A,A1,A2,VAR1,CNTR,NUM) ;Prism Delivery Order Header - Contracting & Procurement
|
|---|
| 5 | ;S A12=$G(^PRC(442,VAR1,4,##,0))
|
|---|
| 6 | N X,STRNG,PRCHNET,PRCHAMT,PRCHSTA,PRCHBL,PRCHLOOP,PRCHTRID,PRCHTRLE,SPFILL,PRCHITFI,PRCHDEFI,LINEITEM
|
|---|
| 7 | S PRCHA0=A
|
|---|
| 8 | S PRCHA1=A1
|
|---|
| 9 | S PRCHDE=0 ;Fine for RC1's - for PO1's need actual DE line count
|
|---|
| 10 | S PRCHITM=1 S:A2="PO1" PRCHITM=$P(PRCHA0,U,14)
|
|---|
| 11 | ;
|
|---|
| 12 | ;#DL SEGEMENT (LINE COUNT) FORMATTED UPTO 3 CHARS. W LEADING ZEROS
|
|---|
| 13 | S PRCHITFI="00"_PRCHITM
|
|---|
| 14 | I $D(PRCHITFI) S PRCHITFI=$E(PRCHITFI,$L(PRCHITFI)-2,99)
|
|---|
| 15 | ;
|
|---|
| 16 | S PRCHTP(1,CNTR+1)="S X=""|DH"";540"
|
|---|
| 17 | ;
|
|---|
| 18 | ;TRANSACTION ID FORMATTED UPTO 15 CHARS W TRAILING SPACES, DASH REMOVED
|
|---|
| 19 | S PRCHTRID=$TR($P(PRCHA0,U),"-")
|
|---|
| 20 | I $D(PRCHTRID) S PRCHTRID=PRCHTRID_" ",PRCHTRID=$E(PRCHTRID,1,15)
|
|---|
| 21 | ;
|
|---|
| 22 | S PRCHTP(1,CNTR+2)="S X=$P(PRCHA0,U,12);533"
|
|---|
| 23 | ;**S PRCHTP(1,CNTR+3)="S X=$P(PRCH(MOD),U);535" ;MOD #
|
|---|
| 24 | S PRCHTP(1,CNTR+4)="S X=$P(PRCHA0,U,16);577" ;OBLIG
|
|---|
| 25 | S PRCHREQ=$P(PRCHA1,U,2),PRCHREQ=$P($G(^DIC(49,PRCHREQ,0)),U)
|
|---|
| 26 | S PRCHTP(1,CNTR+5)="S X=$P(PRCHREQ,U,4);533.2"
|
|---|
| 27 | ;S PRCHTP(1,CNTR+6)="S X=$P(PRCHPHN,U,5);533.4"
|
|---|
| 28 | S PRCHTP(1,CNTR+6)="S X=""999-999-9999"";533.4"
|
|---|
| 29 | S PRCHTP(1,CNTR+7)="S X=$P(PRCHA1,U,3);514.1" ;SHIP TO
|
|---|
| 30 | S PRCHTP(1,CNTR+8)="S X=901;534.6" ;OFF CODE
|
|---|
| 31 | ;VENDOR
|
|---|
| 32 | S X=+PRCHA1 I X]"" S X=$P($G(^PRC(440,X,0)),"^"),X=$E(X,1,25)
|
|---|
| 33 | S PRCHVEN=X,PRCHVEN=PRCHVEN_" "
|
|---|
| 34 | S PRCHVEN=$E(PRCHVEN,1,25)
|
|---|
| 35 | ;
|
|---|
| 36 | S PRCHTP(1,CNTR+9)="S X=PRCHVEN;515.2" ;VENDOR
|
|---|
| 37 | ;** STAPELTON - S PRCHTP(1,CNTR+10)="S X=$P(PRCHNUM,U,7);534.8"
|
|---|
| 38 | S PRCHTP(1,CNTR+11)="S X=$P(PRCHA0,U,10);543"
|
|---|
| 39 | ;** STAPELTONS - PRCHTP(1,CNTR+12)="S X=$P(PRCHLIM,U,7) ;LIMITATION
|
|---|
| 40 | S PRCHTP(1,CNTR+13)="S X=PRCHDE;546"
|
|---|
| 41 | S PRCHTP(1,CNTR+14)="S X=PRCHITM;520"
|
|---|
| 42 | S X=$P(PRCHA0,U,10) D JD^PRCFDLN S DAT=$E(X,1,3)+1700_$E(Y,1,3)
|
|---|
| 43 | ;
|
|---|
| 44 | ;OBLIG. AMT(NET AMT) UPTO 10 CHARS. W LEADING ZEROS 2 & DECIMALS IMPLIED
|
|---|
| 45 | S PRCHNET=$TR($J($P(PRCHA0,U,16),0,2),".")
|
|---|
| 46 | S PRCHAMT="0000000000"_PRCHNET
|
|---|
| 47 | S PRCHAMT=$E(PRCHAMT,$L(PRCHAMT)-9,99)
|
|---|
| 48 | ;
|
|---|
| 49 | ;STATION NO IS REQUIRED FOR SHIP TO FIELD
|
|---|
| 50 | S PRCHSTA=+$P(PRCHA0,U)
|
|---|
| 51 | ;
|
|---|
| 52 | ;VENDOR NAME FORMATTED UPTO 25 CHARS. W TRAILING SPACES
|
|---|
| 53 | ;I $D(PRCHVEN) S PRCHVEN=PRCHVEN_" ",PRCHVEN=$E(PRCHVEN,1,25)
|
|---|
| 54 | ;
|
|---|
| 55 | S STRNG="DH"_"^"_PRCHTRID_"^^^^^^^^^^"_PRCHAMT_"^"_$P(PRCHREQ,U,4)_"^"_$P(PRCHREQ,U,5)_"^"_PRCHSTA_"^"_901_"^"
|
|---|
| 56 | S STRNG=STRNG_PRCHVEN_"^^"_DAT_"^^"_PRCHDE_"^"_PRCHITFI_"^|"
|
|---|
| 57 | S NUM=NUM+1,^TMP($J,"STRING",NUM)=STRNG
|
|---|
| 58 | Q
|
|---|
