- 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
