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