PRCHDP1 ;WISC/RSD/RHD-DISPLAY A P.O. ;2/17/98 15:49
;;5.1;IFCAP;**143**;Oct 20, 2000;Build 3
;Per VHA Directive 2004-038, this routine should not be modified.
S PRCHD0=$G(^PRC(442,D0,0)),PRCHD1=$G(^(1)),X=0
N PRCHSIT1
S PRCHDSIT=$P(PRCHD0,"-",1)
S PRCHSIT1=$S($P($G(^PRC(442,D0,23)),U,7)]"":$P(^(23),U,7),1:$P(PRCHD0,"-"))
S PRCHDSHP="" Q:PRCHD0']"" S:'$D(PRCHPO) PRCHPO=D0
I PRCHD1']"",$D(^PRC(442,D0,4,1,0)) S DIC="^PRC(442,",DA=PRCHPO D EN^DIQ Q
Q:PRCHD1']"" S PRCHDS=0 I +$P(PRCHD0,U,2)'=4,$P(PRCHD1,U,12)="" S PRCHDSHP=$G(^PRC(411,PRCHSIT1,1,+$P(PRCHD1,U,3),0))
I '$T,$P(PRCHD1,U,12)]"" S PRCHDSHP=$G(^PRC(440.2,$P(PRCHD1,U,12),0)),PRCHDS=1 I +PRCHDSHP>0 S $P(PRCHDSHP,U,1)=$E($P($G(^DPT(+PRCHDSHP,0)),U,1),1,21)
S IOP="HOME",%ZIS="",PRCHDST=$G(^PRC(411,PRCHDSIT,0)),PRCHDHSP=$G(^(3)) D ^%ZIS W:$Y>0 @IOF
S PRCHTYPE=$P($G(^PRC(442,D0,23)),U,11)
I PRCHTYPE="P"!(PRCHTYPE="S") S PRCHTYPE="P"
W !,$S($G(PRCHTYPE)="P":"PC ORDER: ",$G(PRCHTYPE)="D":"DELIVER ORDER: ",$D(PRCHNRQ):"REQUISITION: ",1:"PURCHASE ORDER: ")_$P(PRCHD0,U,1),?37,"STATUS: " I +$G(^PRC(442,D0,7))>0 W $E($P($G(^PRCD(442.3,+^(7),0)),U,1),1,34)
W !,"M.O.P.: ",$P($G(^PRCD(442.5,+$P(PRCHD0,U,2),0)),U,1),?37,"LAST PARTIAL RECD.: " S X=0 I $D(^PRC(442,D0,11,0)) S I=0 F S I=$O(^PRC(442,D0,11,I)) Q:I=""!(I'>0) S X=I,Y=+^(I,0)
S:X>0 X=X_" "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) W:X>0 X W !,?37,"REQUESTING SERVICE: ",$S($D(^DIC(49,+$P(PRCHD1,U,2),0)):$P(^(0),U,1),1:"")
N PRCHDV1 S PRCHDV=$G(^PRC(440,+PRCHD1,0)),PRCHDV1=$P(PRCHDV,U,1)
I PRCHDV1="SIMPLIFIED",$P($G(^PRC(442,PRCHPO,24)),U,2)'="" S PRCHDV1=$P($G(^PRC(442,PRCHPO,24)),U,2)
W !,"VENDOR:",?9,PRCHDV1
W ?48,"SHIP TO: ",$P(PRCHDSHP,U,1)
;
; Make sure that the station number is defined for Prosthetics users.
S PRC("SITE")=PRCHDSIT
D FTYP^PRCHFPNT S V(1)=$P(PRCHDV,U,2),V=2,S=1 S:'PRCHDS S(S)=PRCHFTYP,S=S+1
I $P(PRCHDV,U,3)]"" S V(V)=$P(PRCHDV,U,3),V=V+1 S:$P(PRCHDV,U,4)]"" V(V)=$P(PRCHDV,U,4),V=V+1 S:$P(PRCHDV,U,5)]"" V(V)=$P(PRCHDV,U,5),V=V+1
S V(V)=$S($P(PRCHDV,U,6)]"":($P(PRCHDV,U,6)_", "),1:" ")_$P($G(^DIC(5,+$P(PRCHDV,U,7),0)),U,2)_" "_$P(PRCHDV,U,8),V=V+1
S:$P(PRCHDV,U,10)]"" V(V)=$P(PRCHDV,U,10),V=V+1
I $D(^PRC(440,+PRCHD1,2)),$P(^(2),U,1)]"" S V(V)="ACCT # "_$P(^(2),U,1)
I $P(PRCHDST,U,19)="Y",$D(^PRC(440,+PRCHD1,3)),$P(^(3),U,4)'="" S V(6)="FMS Vendor Code: "_$P(^(3),U,4)_$P(^(3),U,5)
I $P(PRCHD1,U,4)="Y" S V(8)=" VERBAL PURCHASE ORDER" S:$P(PRCHD1,U,5)="Y" V(8)=" CONFIRMATION COPY"
S PRCHEDI=$G(^PRC(440,+PRCHD1,3)) I PRCHEDI]"",$P(PRCHEDI,U,2)="Y",$P($G(^PRC(442,D0,12)),U,16)'="n" D S V(8)=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(PRCHDSHP,U,2)]"" S(S)=$P(PRCHDSHP,U,2),S=S+1 S:$P(PRCHDSHP,U,3)]"" S(S)=$P(PRCHDSHP,U,3),S=S+1 S:$P(PRCHDSHP,U,4)]"" S(S)=$P(PRCHDSHP,U,4),S=S+1
S S(S)=$S($P(PRCHDSHP,U,5)]"":($E($P(PRCHDSHP,U,5),1,12)_", "),1:" ")_$P($G(^DIC(5,+$P(PRCHDSHP,U,6),0)),U,2)_" "_$P(PRCHDSHP,U,7),S=S+2
I $P(PRCHDSHP,U,8)]"",'PRCHDS S S(S)="DELIVERY HOURS:",S=S+1,S(S)=$P(PRCHDSHP,U,8)
;S:$P($G(^PRC(442,D0,23)),"^",11)="S" V(1)=""
I $P(PRCHDV,U)="SIMPLIFIED",$P($G(^PRC(442,PRCHPO,24)),U,2)'="" S V(1)=""
F I=1:1:7 W ! W:$D(V(I)) ?9,V(I) W:$D(S(I)) ?57,S(I)
W ! W:$D(V(8)) V(8) W:$D(S(8)) ?57,S(8) W !
I $P(PRCHD1,U,11)]"" W ?38,"DELIVERY LOCATION: ",$P(PRCHD1,U,11),!
F I=1:1:80 W "_"
I $P($G(^PRC(442,D0,24)),U,3)="RMPR" D K RMPRPO,RMPR664,RMPRR3
. S RMPRPO=$P($P($G(^PRC(442,D0,0)),U),"-",2) Q:RMPRPO=""
. S RMPR664=$O(^RMPR(664,"G",RMPRPO,0)) Q:RMPR664'>0
. S RMPRR3=$G(^RMPR(664,RMPR664,3)) I $P(RMPRR3,U)="",$P(RMPRR3,U,4)="" Q
. W !,"Prosthetics Delivery information:"
. W !,?7,"Delivery To: ",$E($P(RMPRR3,U),1,50)
. W !,?9,"Attention: ",$E($P(RMPRR3,U,4),1,50)
. W ! F I=1:1:80 W "_"
FOB W !,"FOB POINT: ",$S("O"=$E($P(PRCHD1,U,6)):"ORIGIN","D"=$E($P(PRCHD1,U,6)):"DESTINATION",1:""),?29,"|","PROPOSAL: " S DIWL=1,DIWR=16,DIWF="",X=$P(PRCHD1,U,8) K ^UTILITY($J,"W") D DIWP^PRCUTL($G(DA))
K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
W ?40,$G(^TMP($J,"W",1,1,0)),?57,"|AUTHORITY: ",!,"COST CENTER: ",$P(PRCHD0,U,5),?29,"|",?40,$G(^TMP($J,"W",1,2,0)),?57,"| "
S Y=0 F I=1:1 S Y=$O(^PRC(442,D0,14,Y)) Q:'Y W:I>1 "," W $P($G(^PRC(442.4,+^(Y,0),0)),U,2)
W !,"TYPE: ",$P(PRCHD1,U,14) D TY W X,?29,"|",?40,$G(^TMP($J,"W",1,3,0)),?57,"|"_$S($P($G(^PRC(442,D0,23)),U,11)'="":"BUYER",1:"AGENT")_":"
DIS W !,"DELIVER ON/BEFORE " S Y=$P(PRCHD0,U,10) D DT W ?29,"|","CONTRACT: "
S Y=+$P(PRCHD1,U,10),Y=$P($G(^VA(200,Y,0)),U,1) W ?57,"| ",$P(Y,",",2)," ",$P(Y,",",1)
W !,"DISCOUNT TERM: " S X=0 I $D(^PRC(442,D0,5,0)) F I=1:1:2 S X=$O(^PRC(442,D0,5,X)) Q:X=""!(X'>0) W $P(^(X,0),U,4),$P(^(0),U,1) W:$P(^(0),U,1)=+$P(^(0),U,1) "%" W $P(^(0),U,2)," "
CON K Y S X=0 F I=1:1:3 S:(X'="") X=$O(^PRC(442,D0,2,"AC",X)) D:X'="" D:I=2 APP W ?29,"|" W:$D(Y) ?38,$S($D(^(Y)):$J(^(Y),3),1:"") W:X'="" ?41,X W ?57,"|" D DAT:I=1,EST:I=2,TOT:I=3 W ! K Y
.S:$D(^(X)) Y=$O(^(X,0))
F I=1:1:80 W "-"
G ^PRCHDP2
APP W "APP: ",$P(PRCHD0,U,4),"-",$P($P(PRCHD0,U,3)," ",1) Q
DAT W "DATE: " S Y=$P(PRCHD1,U,15) D DT Q
TOT W "TOTAL: ",$J($P(PRCHD0,U,15),8,2) Q
EST S Y=$S($D(^PRC(442,D0,7)):$P(^(7),U,3),1:"") Q:Y'="Y" W "ESTIMATED" Q
DT I Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700
Q
TY S X=+$P(PRCHD1,U,7),X=$P($G(^PRCD(420.8,X,0)),U,1),X=$S(X=2:"PURCHASE ORDER",X="B":"DELIVERY & PURCHASE ORDER",X="":"",1:"DELIVERY ORDER")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDP1 5611 printed Mar 13, 2025@21:11:29 Page 2
PRCHDP1 ;WISC/RSD/RHD-DISPLAY A P.O. ;2/17/98 15:49
+1 ;;5.1;IFCAP;**143**;Oct 20, 2000;Build 3
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 SET PRCHD0=$GET(^PRC(442,D0,0))
SET PRCHD1=$GET(^(1))
SET X=0
+4 NEW PRCHSIT1
+5 SET PRCHDSIT=$PIECE(PRCHD0,"-",1)
+6 SET PRCHSIT1=$SELECT($PIECE($GET(^PRC(442,D0,23)),U,7)]"":$PIECE(^(23),U,7),1:$PIECE(PRCHD0,"-"))
+7 SET PRCHDSHP=""
if PRCHD0']""
QUIT
if '$DATA(PRCHPO)
SET PRCHPO=D0
+8 IF PRCHD1']""
IF $DATA(^PRC(442,D0,4,1,0))
SET DIC="^PRC(442,"
SET DA=PRCHPO
DO EN^DIQ
QUIT
+9 if PRCHD1']""
QUIT
SET PRCHDS=0
IF +$PIECE(PRCHD0,U,2)'=4
IF $PIECE(PRCHD1,U,12)=""
SET PRCHDSHP=$GET(^PRC(411,PRCHSIT1,1,+$PIECE(PRCHD1,U,3),0))
+10 IF '$TEST
IF $PIECE(PRCHD1,U,12)]""
SET PRCHDSHP=$GET(^PRC(440.2,$PIECE(PRCHD1,U,12),0))
SET PRCHDS=1
IF +PRCHDSHP>0
SET $PIECE(PRCHDSHP,U,1)=$EXTRACT($PIECE($GET(^DPT(+PRCHDSHP,0)),U,1),1,21)
+11 SET IOP="HOME"
SET %ZIS=""
SET PRCHDST=$GET(^PRC(411,PRCHDSIT,0))
SET PRCHDHSP=$GET(^(3))
DO ^%ZIS
if $Y>0
WRITE @IOF
+12 SET PRCHTYPE=$PIECE($GET(^PRC(442,D0,23)),U,11)
+13 IF PRCHTYPE="P"!(PRCHTYPE="S")
SET PRCHTYPE="P"
+14 WRITE !,$SELECT($GET(PRCHTYPE)="P":"PC ORDER: ",$GET(PRCHTYPE)="D":"DELIVER ORDER: ",$DATA(PRCHNRQ):"REQUISITION: ",1:"PURCHASE ORDER: ")_$PIECE(PRCHD0,U,1),?37,"STATUS: "
IF +$GET(^PRC(442,D0,7))>0
WRITE $EXTRACT($PIECE($GET(^PRCD(442.3,+^(7),0)),U,1),1,34)
+15 WRITE !,"M.O.P.: ",$PIECE($GET(^PRCD(442.5,+$PIECE(PRCHD0,U,2),0)),U,1),?37,"LAST PARTIAL RECD.: "
SET X=0
IF $DATA(^PRC(442,D0,11,0))
SET I=0
FOR
SET I=$ORDER(^PRC(442,D0,11,I))
if I=""!(I'>0)
QUIT
SET X=I
SET Y=+^(I,0)
+16 if X>0
SET X=X_" "_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
if X>0
WRITE X
WRITE !,?37,"REQUESTING SERVICE: ",$SELECT($DATA(^DIC(49,+$PIECE(PRCHD1,U,2),0)):$PIECE(^(0),U,1),1:"")
+17 NEW PRCHDV1
SET PRCHDV=$GET(^PRC(440,+PRCHD1,0))
SET PRCHDV1=$PIECE(PRCHDV,U,1)
+18 IF PRCHDV1="SIMPLIFIED"
IF $PIECE($GET(^PRC(442,PRCHPO,24)),U,2)'=""
SET PRCHDV1=$PIECE($GET(^PRC(442,PRCHPO,24)),U,2)
+19 WRITE !,"VENDOR:",?9,PRCHDV1
+20 WRITE ?48,"SHIP TO: ",$PIECE(PRCHDSHP,U,1)
+21 ;
+22 ; Make sure that the station number is defined for Prosthetics users.
+23 SET PRC("SITE")=PRCHDSIT
+24 DO FTYP^PRCHFPNT
SET V(1)=$PIECE(PRCHDV,U,2)
SET V=2
SET S=1
if 'PRCHDS
SET S(S)=PRCHFTYP
SET S=S+1
+25 IF $PIECE(PRCHDV,U,3)]""
SET V(V)=$PIECE(PRCHDV,U,3)
SET V=V+1
if $PIECE(PRCHDV,U,4)]""
SET V(V)=$PIECE(PRCHDV,U,4)
SET V=V+1
if $PIECE(PRCHDV,U,5)]""
SET V(V)=$PIECE(PRCHDV,U,5)
SET V=V+1
+26 SET V(V)=$SELECT($PIECE(PRCHDV,U,6)]"":($PIECE(PRCHDV,U,6)_", "),1:" ")_$PIECE($GET(^DIC(5,+$PIECE(PRCHDV,U,7),0)),U,2)_" "_$PIECE(PRCHDV,U,8)
SET V=V+1
+27 if $PIECE(PRCHDV,U,10)]""
SET V(V)=$PIECE(PRCHDV,U,10)
SET V=V+1
+28 IF $DATA(^PRC(440,+PRCHD1,2))
IF $PIECE(^(2),U,1)]""
SET V(V)="ACCT # "_$PIECE(^(2),U,1)
+29 IF $PIECE(PRCHDST,U,19)="Y"
IF $DATA(^PRC(440,+PRCHD1,3))
IF $PIECE(^(3),U,4)'=""
SET V(6)="FMS Vendor Code: "_$PIECE(^(3),U,4)_$PIECE(^(3),U,5)
+30 IF $PIECE(PRCHD1,U,4)="Y"
SET V(8)=" VERBAL PURCHASE ORDER"
if $PIECE(PRCHD1,U,5)="Y"
SET V(8)=" CONFIRMATION COPY"
+31 SET PRCHEDI=$GET(^PRC(440,+PRCHD1,3))
IF PRCHEDI]""
IF $PIECE(PRCHEDI,U,2)="Y"
IF $PIECE($GET(^PRC(442,D0,12)),U,16)'="n"
Begin DoDot:1
+32 SET PRCHEDIT=""
SET PRCHEDIT=$PIECE($GET(^PRC(442,D0,12)),U,14)
+33 SET PRCHEDIT=$SELECT(PRCHEDIT'="":"*EDI EMERGENCY ORDER-"_$PIECE($GET(^PRC(443.4,PRCHEDIT,0)),U)_"*",1:"*EDI ORDER*")
QUIT
End DoDot:1
SET V(8)=PRCHEDIT_" DO NOT MAIL"
+34 KILL PRCHEDI,PRCHEDIT
+35 if $PIECE(PRCHDSHP,U,2)]""
SET S(S)=$PIECE(PRCHDSHP,U,2)
SET S=S+1
if $PIECE(PRCHDSHP,U,3)]""
SET S(S)=$PIECE(PRCHDSHP,U,3)
SET S=S+1
if $PIECE(PRCHDSHP,U,4)]""
SET S(S)=$PIECE(PRCHDSHP,U,4)
SET S=S+1
+36 SET S(S)=$SELECT($PIECE(PRCHDSHP,U,5)]"":($EXTRACT($PIECE(PRCHDSHP,U,5),1,12)_", "),1:" ")_$PIECE($GET(^DIC(5,+$PIECE(PRCHDSHP,U,6),0)),U,2)_" "_$PIECE(PRCHDSHP,U,7)
SET S=S+2
+37 IF $PIECE(PRCHDSHP,U,8)]""
IF 'PRCHDS
SET S(S)="DELIVERY HOURS:"
SET S=S+1
SET S(S)=$PIECE(PRCHDSHP,U,8)
+38 ;S:$P($G(^PRC(442,D0,23)),"^",11)="S" V(1)=""
+39 IF $PIECE(PRCHDV,U)="SIMPLIFIED"
IF $PIECE($GET(^PRC(442,PRCHPO,24)),U,2)'=""
SET V(1)=""
+40 FOR I=1:1:7
WRITE !
if $DATA(V(I))
WRITE ?9,V(I)
if $DATA(S(I))
WRITE ?57,S(I)
+41 WRITE !
if $DATA(V(8))
WRITE V(8)
if $DATA(S(8))
WRITE ?57,S(8)
WRITE !
+42 IF $PIECE(PRCHD1,U,11)]""
WRITE ?38,"DELIVERY LOCATION: ",$PIECE(PRCHD1,U,11),!
+43 FOR I=1:1:80
WRITE "_"
+44 IF $PIECE($GET(^PRC(442,D0,24)),U,3)="RMPR"
Begin DoDot:1
+45 SET RMPRPO=$PIECE($PIECE($GET(^PRC(442,D0,0)),U),"-",2)
if RMPRPO=""
QUIT
+46 SET RMPR664=$ORDER(^RMPR(664,"G",RMPRPO,0))
if RMPR664'>0
QUIT
+47 SET RMPRR3=$GET(^RMPR(664,RMPR664,3))
IF $PIECE(RMPRR3,U)=""
IF $PIECE(RMPRR3,U,4)=""
QUIT
+48 WRITE !,"Prosthetics Delivery information:"
+49 WRITE !,?7,"Delivery To: ",$EXTRACT($PIECE(RMPRR3,U),1,50)
+50 WRITE !,?9,"Attention: ",$EXTRACT($PIECE(RMPRR3,U,4),1,50)
+51 WRITE !
FOR I=1:1:80
WRITE "_"
End DoDot:1
KILL RMPRPO,RMPR664,RMPRR3
FOB WRITE !,"FOB POINT: ",$SELECT("O"=$EXTRACT($PIECE(PRCHD1,U,6)):"ORIGIN","D"=$EXTRACT($PIECE(PRCHD1,U,6)):"DESTINATION",1:""),?29,"|","PROPOSAL: "
SET DIWL=1
SET DIWR=16
SET DIWF=""
SET X=$PIECE(PRCHD1,U,8)
KILL ^UTILITY($JOB,"W")
DO DIWP^PRCUTL($GET(DA))
+1 KILL ^TMP($JOB,"W")
SET %X="^UTILITY($J,""W"","
SET %Y="^TMP($J,""W"","
DO %XY^%RCR
+2 WRITE ?40,$GET(^TMP($JOB,"W",1,1,0)),?57,"|AUTHORITY: ",!,"COST CENTER: ",$PIECE(PRCHD0,U,5),?29,"|",?40,$GET(^TMP($JOB,"W",1,2,0)),?57,"| "
+3 SET Y=0
FOR I=1:1
SET Y=$ORDER(^PRC(442,D0,14,Y))
if 'Y
QUIT
if I>1
WRITE ","
WRITE $PIECE($GET(^PRC(442.4,+^(Y,0),0)),U,2)
+4 WRITE !,"TYPE: ",$PIECE(PRCHD1,U,14)
DO TY
WRITE X,?29,"|",?40,$GET(^TMP($JOB,"W",1,3,0)),?57,"|"_$SELECT($PIECE($GET(^PRC(442,D0,23)),U,11)'="":"BUYER",1:"AGENT")_":"
DIS WRITE !,"DELIVER ON/BEFORE "
SET Y=$PIECE(PRCHD0,U,10)
DO DT
WRITE ?29,"|","CONTRACT: "
+1 SET Y=+$PIECE(PRCHD1,U,10)
SET Y=$PIECE($GET(^VA(200,Y,0)),U,1)
WRITE ?57,"| ",$PIECE(Y,",",2)," ",$PIECE(Y,",",1)
+2 WRITE !,"DISCOUNT TERM: "
SET X=0
IF $DATA(^PRC(442,D0,5,0))
FOR I=1:1:2
SET X=$ORDER(^PRC(442,D0,5,X))
if X=""!(X'>0)
QUIT
WRITE $PIECE(^(X,0),U,4),$PIECE(^(0),U,1)
if $PIECE(^(0),U,1)=+$PIECE(^(0),U,1)
WRITE "%"
WRITE $PIECE(^(0),U,2)," "
CON KILL Y
SET X=0
FOR I=1:1:3
if (X'="")
SET X=$ORDER(^PRC(442,D0,2,"AC",X))
if X'=""
Begin DoDot:1
+1 if $DATA(^(X))
SET Y=$ORDER(^(X,0))
End DoDot:1
if I=2
DO APP
WRITE ?29,"|"
if $DATA(Y)
WRITE ?38,$SELECT($DATA(^(Y)):$JUSTIFY(^(Y),3),1:"")
if X'=""
WRITE ?41,X
WRITE ?57,"|"
if I=1
DO DAT
if I=2
DO EST
if I=3
DO TOT
WRITE !
KILL Y
+2 FOR I=1:1:80
WRITE "-"
+3 GOTO ^PRCHDP2
APP WRITE "APP: ",$PIECE(PRCHD0,U,4),"-",$PIECE($PIECE(PRCHD0,U,3)," ",1)
QUIT
DAT WRITE "DATE: "
SET Y=$PIECE(PRCHD1,U,15)
DO DT
QUIT
TOT WRITE "TOTAL: ",$JUSTIFY($PIECE(PRCHD0,U,15),8,2)
QUIT
EST SET Y=$SELECT($DATA(^PRC(442,D0,7)):$PIECE(^(7),U,3),1:"")
if Y'="Y"
QUIT
WRITE "ESTIMATED"
QUIT
DT IF Y
WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
+1 QUIT
TY SET X=+$PIECE(PRCHD1,U,7)
SET X=$PIECE($GET(^PRCD(420.8,X,0)),U,1)
SET X=$SELECT(X=2:"PURCHASE ORDER",X="B":"DELIVERY & PURCHASE ORDER",X="":"",1:"DELIVERY ORDER")
+1 QUIT
