PRCHFPT0 ;WISC/RSD/RHD/BGJ-CONTINUATION--PRINT FREE FORM 2138 ;4/21/99 18:05
V ;;5.1;IFCAP;**7**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
STP ;PRINT HEADER ON FIRST PAGE
S Y=$P(PRCH1,U,9) W:$Y>0 @IOF W !,?5,$S(Y="EM":"**EMERGENCY**",Y="SP":"*SPECIAL*",1:"") W:$D(PRCHREPR) ?20,"*REPRINT* "
S PRCHTYPE=$P($G(^PRC(442,D0,23)),U,11)
W ?28,$S("D"=PRCHTYPE:"DELIVERY ORDER",PRCHTYPE]"":"PURCHASE CARD ORDER",PRCHDES="US":" USING SERVICE COPY",$D(PRCHNRQ):"REQUISITION FOR SUPPLIES OR SERVICES",1:"PURCHASE ORDER FOR SUPPLIES OR SERVICES"),?70
I $P(PRCHST,U,15)="Y" S %H=$H D YX^%DTC W "("_Y_")"
W !?28,$E(PRCHULN,1,39),!,"ISSUING OFFICE:",?50,"REQUESTING SERVICE:",! S:'$D(PRC("SITE")) PRC("SITE")=+PRCH0 D FTYP^PRCHFPNT W "Dept. of Veterans Affairs "_$P(PRCHFTYP," ",2,99),?61
S Y=$G(^DIC(49,+$P(PRCH1,U,2),0)) W $P(Y,U,1) W:$P(Y,U,8)]"" "(",$P(Y,U,8),")" W !,$P(PRCHHSP,U,1)," ",$P(PRCHHSP,U,2)
W !,$P(PRCHHSP,U,3),", ",$P($G(^DIC(5,+$P(PRCHHSP,U,4),0)),U,2)," ",$P(PRCHHSP,U,5),?61,"DEL. TO: ",$P(PRCH1,U,11),!,PRCHULN
S PRCHV=$G(^PRC(440,+PRCH1,0),U_">> No info for vendor: "_PRCH1)
N T S T=$P(PRCHV,U,1) I T="SIMPLIFIED" N R S R=$P($G(^PRC(442,D0,24)),U,2) I R]"" S T=R
W !,"VENDOR:",?53,"|SHIP TO:",!,?9,T,?53,"|",?62,$P(PRCHSHP,U,1) W:'PRCHS " ",$P($P(PRCH0,U,1),"-",2)
S S=1 S:'PRCHS S(S)=PRCHFTYP,S=S+1
I S V=1
E D
. S V(1)=$P(PRCHV,U,2),V=2
. I $P(PRCHV,U,3)]"" S V(V)=$P(PRCHV,U,3),V=V+1 S:$P(PRCHV,U,4)]"" V(V)=$P(PRCHV,U,4),V=V+1 S:$P(PRCHV,U,5)]"" V(V)=$P(PRCHV,U,5),V=V+1
. S V(V)=$S($P(PRCHV,U,6)]"":($P(PRCHV,U,6)_" "),1:"")_$P($G(^DIC(5,+$P(PRCHV,U,7),0)),U,2)_" "_$P(PRCHV,U,8),V=$S(V<5:3,1:2)+V
I $D(^PRC(440,+PRCH1,2)) S:$P(^(2),U,1)]"" V(V)="ACCT # "_$P(^(2),U,1),V=V+1 S V(V)=""
S:$P(PRCHV,U,10)]"" V(V)=$P(PRCHV,U,10) S PRCVFAX=$P($G(^PRC(440,+PRCH1,10)),U,6) S:PRCVFAX'="" V(V)=$G(V(V))_" FAX: "_PRCVFAX K PRCVFAX
I V<9 S V=V+1,V(V)=""
I $P(PRCHST,U,19)="Y",$D(^PRC(440,+PRCH1,3)),$P(^(3),U,4)'="" S V(V)=V(V)_"FMS Vendor Code: "_$P(^(3),U,4)_$P(^(3),U,5)
I $P(PRCH1,U,4)="Y" S V(10)=" VERBAL PURCHASE ORDER" S:$P(PRCH1,U,5)="Y" V(10)=" CONFIRMATION COPY, PLEASE DO NOT DUPLICATE"
S PRCHEDI=$G(^PRC(440,+PRCH1,3)) I PRCHEDI]"",$P(PRCHEDI,U,2)="Y",$P($G(^PRC(442,D0,12)),U,16)'="n" D S V(10)=PRCHEDIT_" DO NOT MAIL"
.S PRCHEDIT="",PRCHEDIT=$P($G(^PRC(442,D0,12)),U,14)
.S PRCHEDIT=$S(PRCHEDIT'="":"*EDI EMERGENCY ORDER-"_$P($G(^PRC(443.4,PRCHEDIT,0)),U)_"*",1:"*EDI ORDER*") Q
K PRCHEDI,PRCHEDIT
S:$P(PRCHSHP,U,2)]"" S(S)=$P(PRCHSHP,U,2),S=S+1 S:$P(PRCHSHP,U,3)]"" S(S)=$P(PRCHSHP,U,3),S=S+1 S:$P(PRCHSHP,U,4)]"" S(S)=$P(PRCHSHP,U,4),S=S+1
S S(S)=$S($P(PRCHSHP,U,5)]"":($P(PRCHSHP,U,5)_", "),1:" ")_$P($G(^DIC(5,+$P(PRCHSHP,U,6),0)),U,2)_" "_$P(PRCHSHP,U,7),S=S+2
I $P(PRCHSHP,U,8)]"",'PRCHS S S(S)="DELIVERY HOURS:",S=S+1,S(S)=$P(PRCHSHP,U,8)
F I=1:1:9 W ! W:$D(V(I)) ?9,V(I) W ?53,"|" W:$D(S(I)) ?62,S(I)
W ! W:$D(V(10)) ?5,V(10) W ?53,"|" W:$D(S(10)) ?62,S(10)
F I=1:1:96 W @IOBS
W $E(PRCHULN,1,53),"|",$E(PRCHULN,1,42)
G ^PRCHFPT1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPT0 3088 printed Dec 13, 2024@02:07:38 Page 2
PRCHFPT0 ;WISC/RSD/RHD/BGJ-CONTINUATION--PRINT FREE FORM 2138 ;4/21/99 18:05
V ;;5.1;IFCAP;**7**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
STP ;PRINT HEADER ON FIRST PAGE
+1 SET Y=$PIECE(PRCH1,U,9)
if $Y>0
WRITE @IOF
WRITE !,?5,$SELECT(Y="EM":"**EMERGENCY**",Y="SP":"*SPECIAL*",1:"")
if $DATA(PRCHREPR)
WRITE ?20,"*REPRINT* "
+2 SET PRCHTYPE=$PIECE($GET(^PRC(442,D0,23)),U,11)
+3 WRITE ?28,$SELECT("D"=PRCHTYPE:"DELIVERY ORDER",PRCHTYPE]"":"PURCHASE CARD ORDER",PRCHDES="US":" USING SERVICE COPY",$DATA(PRCHNRQ):"REQUISITION FOR SUPPLIES OR SERVICES",1:"PURCHASE ORDER FOR SUPPLIES OR SERVICES"),?70
+4 IF $PIECE(PRCHST,U,15)="Y"
SET %H=$HOROLOG
DO YX^%DTC
WRITE "("_Y_")"
+5 WRITE !?28,$EXTRACT(PRCHULN,1,39),!,"ISSUING OFFICE:",?50,"REQUESTING SERVICE:",!
if '$DATA(PRC("SITE"))
SET PRC("SITE")=+PRCH0
DO FTYP^PRCHFPNT
WRITE "Dept. of Veterans Affairs "_$PIECE(PRCHFTYP," ",2,99),?61
+6 SET Y=$GET(^DIC(49,+$PIECE(PRCH1,U,2),0))
WRITE $PIECE(Y,U,1)
if $PIECE(Y,U,8)]""
WRITE "(",$PIECE(Y,U,8),")"
WRITE !,$PIECE(PRCHHSP,U,1)," ",$PIECE(PRCHHSP,U,2)
+7 WRITE !,$PIECE(PRCHHSP,U,3),", ",$PIECE($GET(^DIC(5,+$PIECE(PRCHHSP,U,4),0)),U,2)," ",$PIECE(PRCHHSP,U,5),?61,"DEL. TO: ",$PIECE(PRCH1,U,11),!,PRCHULN
+8 SET PRCHV=$GET(^PRC(440,+PRCH1,0),U_">> No info for vendor: "_PRCH1)
+9 NEW T
SET T=$PIECE(PRCHV,U,1)
IF T="SIMPLIFIED"
NEW R
SET R=$PIECE($GET(^PRC(442,D0,24)),U,2)
IF R]""
SET T=R
+10 WRITE !,"VENDOR:",?53,"|SHIP TO:",!,?9,T,?53,"|",?62,$PIECE(PRCHSHP,U,1)
if 'PRCHS
WRITE " ",$PIECE($PIECE(PRCH0,U,1),"-",2)
+11 SET S=1
if 'PRCHS
SET S(S)=PRCHFTYP
SET S=S+1
+12 IF $TEST
SET V=1
+13 IF '$TEST
Begin DoDot:1
+14 SET V(1)=$PIECE(PRCHV,U,2)
SET V=2
+15 IF $PIECE(PRCHV,U,3)]""
SET V(V)=$PIECE(PRCHV,U,3)
SET V=V+1
if $PIECE(PRCHV,U,4)]""
SET V(V)=$PIECE(PRCHV,U,4)
SET V=V+1
if $PIECE(PRCHV,U,5)]""
SET V(V)=$PIECE(PRCHV,U,5)
SET V=V+1
+16 SET V(V)=$SELECT($PIECE(PRCHV,U,6)]"":($PIECE(PRCHV,U,6)_" "),1:"")_$PIECE($GET(^DIC(5,+$PIECE(PRCHV,U,7),0)),U,2)_" "_$PIECE(PRCHV,U,8)
SET V=$SELECT(V<5:3,1:2)+V
End DoDot:1
+17 IF $DATA(^PRC(440,+PRCH1,2))
if $PIECE(^(2),U,1)]""
SET V(V)="ACCT # "_$PIECE(^(2),U,1)
SET V=V+1
SET V(V)=""
+18 if $PIECE(PRCHV,U,10)]""
SET V(V)=$PIECE(PRCHV,U,10)
SET PRCVFAX=$PIECE($GET(^PRC(440,+PRCH1,10)),U,6)
if PRCVFAX'=""
SET V(V)=$GET(V(V))_" FAX: "_PRCVFAX
KILL PRCVFAX
+19 IF V<9
SET V=V+1
SET V(V)=""
+20 IF $PIECE(PRCHST,U,19)="Y"
IF $DATA(^PRC(440,+PRCH1,3))
IF $PIECE(^(3),U,4)'=""
SET V(V)=V(V)_"FMS Vendor Code: "_$PIECE(^(3),U,4)_$PIECE(^(3),U,5)
+21 IF $PIECE(PRCH1,U,4)="Y"
SET V(10)=" VERBAL PURCHASE ORDER"
if $PIECE(PRCH1,U,5)="Y"
SET V(10)=" CONFIRMATION COPY, PLEASE DO NOT DUPLICATE"
+22 SET PRCHEDI=$GET(^PRC(440,+PRCH1,3))
IF PRCHEDI]""
IF $PIECE(PRCHEDI,U,2)="Y"
IF $PIECE($GET(^PRC(442,D0,12)),U,16)'="n"
Begin DoDot:1
+23 SET PRCHEDIT=""
SET PRCHEDIT=$PIECE($GET(^PRC(442,D0,12)),U,14)
+24 SET PRCHEDIT=$SELECT(PRCHEDIT'="":"*EDI EMERGENCY ORDER-"_$PIECE($GET(^PRC(443.4,PRCHEDIT,0)),U)_"*",1:"*EDI ORDER*")
QUIT
End DoDot:1
SET V(10)=PRCHEDIT_" DO NOT MAIL"
+25 KILL PRCHEDI,PRCHEDIT
+26 if $PIECE(PRCHSHP,U,2)]""
SET S(S)=$PIECE(PRCHSHP,U,2)
SET S=S+1
if $PIECE(PRCHSHP,U,3)]""
SET S(S)=$PIECE(PRCHSHP,U,3)
SET S=S+1
if $PIECE(PRCHSHP,U,4)]""
SET S(S)=$PIECE(PRCHSHP,U,4)
SET S=S+1
+27 SET S(S)=$SELECT($PIECE(PRCHSHP,U,5)]"":($PIECE(PRCHSHP,U,5)_", "),1:" ")_$PIECE($GET(^DIC(5,+$PIECE(PRCHSHP,U,6),0)),U,2)_" "_$PIECE(PRCHSHP,U,7)
SET S=S+2
+28 IF $PIECE(PRCHSHP,U,8)]""
IF 'PRCHS
SET S(S)="DELIVERY HOURS:"
SET S=S+1
SET S(S)=$PIECE(PRCHSHP,U,8)
+29 FOR I=1:1:9
WRITE !
if $DATA(V(I))
WRITE ?9,V(I)
WRITE ?53,"|"
if $DATA(S(I))
WRITE ?62,S(I)
+30 WRITE !
if $DATA(V(10))
WRITE ?5,V(10)
WRITE ?53,"|"
if $DATA(S(10))
WRITE ?62,S(10)
+31 FOR I=1:1:96
WRITE @IOBS
+32 WRITE $EXTRACT(PRCHULN,1,53),"|",$EXTRACT(PRCHULN,1,42)
+33 GOTO ^PRCHFPT1
