PRCPAGRO ;WISC/RFJ,DXH/VAC - autogenerate print suggested distribution order ; 2/19/07 12:46pm
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
;*98 Modified to accommodate On-Demand items.
Q
;
;
ORDER ; print order to create
; for ^tmp($j,"prcpag","ok",vendorname,vendorda,groupname,
; xxx,itemda) where xxx equals whse:nsn; prim or seco:descr
N %,%H,%I,D,DESCNSN,GNM,ITEMDA,NOW,ODITEM,ORDER,PAGE,SCREEN,TOTCOST,VDA,VNM,X,Y
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO
S VNM="" F S VNM=$O(^TMP($J,"PRCPAG","OK",VNM)) Q:VNM=""!($G(PRCPFLAG)) S VDA=0 F S VDA=$O(^TMP($J,"PRCPAG","OK",VNM,VDA)) Q:'VDA!($G(PRCPFLAG)) D
. I PAGE>1 D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG)
. S TOTCOST=0,ORDER=$G(^TMP($J,"PRCPAG","VO",VDA)) S:ORDER="" ORDER="<< UNABLE TO CREATE ORDER >>" D H
. S GNM="" F S GNM=$O(^TMP($J,"PRCPAG","OK",VNM,VDA,GNM)) Q:GNM=""!($G(PRCPFLAG)) D
.. I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
.. W !!?12,"GROUP CATEGORY: ",$S(GNM=" ":"<< NOT SPECIFIED >>",1:GNM)
.. S DESCNSN="" F S DESCNSN=$O(^TMP($J,"PRCPAG","OK",VNM,VDA,GNM,DESCNSN)) Q:DESCNSN=""!($G(PRCPFLAG)) D
... S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPAG","OK",VNM,VDA,GNM,DESCNSN,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) S D=^(ITEMDA) D
.... S %=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
.... S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
.... I PRCP("DPTYPE")="W" D
..... W !!,ITEMDA,?7 W:PRCP("DPTYPE")'="W" $E(%,1,35) W:PRCP("DPTYPE")="W" $E(%,1,20),?31,$$NSN^PRCPUX1(ITEMDA) W ?50,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),9),$J($P(D,"^",12),9),$J($P(D,"^",15),6),$J($P(D,"^",16),6)
.... I PRCP("DPTYPE")'="W" D
..... W !!,ITEMDA
..... I ODITEM="Y" W ?8,"D "
..... I ODITEM'="Y" W ?8," "
..... W:PRCP("DPTYPE")'="W" $E(%,1,32) W:PRCP("DPTYPE")="W" $E(%,1,17)
.... W ?31,$$NSN^PRCPUX1(ITEMDA) W ?50,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),9),$J($P(D,"^",12),9),$J($P(D,"^",15),6),$J($P(D,"^",16),6)
.... W !,$J("ONHAND",8),$J("+DUEIN",8),$J("-DUEOUT",8),$J("=AVAIL",8),$J("STAND",7),$J("OPTN",8),$J("LEVEL",8),$J("CONV",7),$J("ORDER",8),$J("UNIT$",10)
.... W !,$J(+$P(D,"^"),8),$J(+$P(D,"^",2),8),$J(+$P(D,"^",3),8),$J(+$P(D,"^",4),8),$J(+$P(D,"^",5),7),$S($P(D,"^",7)="STA":"*",1:" "),$J(+$P(D,"^",6),7),$S($P(D,"^",7)="OPT":"*",1:" ")
.... W $J(+$P(D,"^",8),7),$S($P(D,"^",9)="*":"*",1:" "),$J(+$P(D,"^",10),6),$J(+$P(D,"^",11),8),$J(+$P(D,"^",14),10,3)
.... S TOTCOST=TOTCOST+$J($P(D,"^",11)*$P(D,"^",14),0,2)
.... I $Y>(IOSL-9) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H W !!?12,"GROUP CATEGORY: ",$S(GNM=" ":"<< NOT SPECIFIED >>",1:GNM)
. I $G(PRCPFLAG) Q
. I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
. W !!,"TOTAL COST OF ORDER: ",TOTCOST
I $G(PRCPFLAG) Q
D END^PRCPUREP
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"AUTO-GEN: SUGGESTED ORDERS FOR ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
W !?5,"ORDERING FROM ",$S(PRCP("DPTYPE")="S":"PRIMARY INVENTORY POINT",1:"VENDOR"),": ",VNM
W !?5,$S(PRCP("DPTYPE")="S":"DISTRIBUTION ORDER",1:"REPETITIVE ITEM LIST")," NUMBER: ",ORDER
W !?50,$J($S(PRCP("DPTYPE")="S":"SECONDARY",PRCP("DPTYPE")="P":"PRIMARY",1:"WHSE"),9),$J($S(PRCP("DPTYPE")="S":"PRIMARY",1:"VENDOR"),9),$J("ISSUE",6),$J("ISSUE",6)
W !,"IM#"
I PRCP("DPTYPE")="W" D
. W ?7,"DESCRIPTION"
I PRCP("DPTYPE")'="W" D
. W ?8,"OD",?11,"DESCRIPTION"
W:PRCP("DPTYPE") ?31,"NSN" W ?50,$J("UNIT/ISS",9),$J("UNIT/ISS",9),$J("MINIM",6),$J("MULT",6)
S %="",$P(%,"-",81)="" W !,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAGRO 3584 printed Sep 23, 2025@19:48:43 Page 2
PRCPAGRO ;WISC/RFJ,DXH/VAC - autogenerate print suggested distribution order ; 2/19/07 12:46pm
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;*98 Modified to accommodate On-Demand items.
+4 QUIT
+5 ;
+6 ;
ORDER ; print order to create
+1 ; for ^tmp($j,"prcpag","ok",vendorname,vendorda,groupname,
+2 ; xxx,itemda) where xxx equals whse:nsn; prim or seco:descr
+3 NEW %,%H,%I,D,DESCNSN,GNM,ITEMDA,NOW,ODITEM,ORDER,PAGE,SCREEN,TOTCOST,VDA,VNM,X,Y
+4 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
+5 SET VNM=""
FOR
SET VNM=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM))
if VNM=""!($GET(PRCPFLAG))
QUIT
SET VDA=0
FOR
SET VDA=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM,VDA))
if 'VDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+6 IF PAGE>1
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
+7 SET TOTCOST=0
SET ORDER=$GET(^TMP($JOB,"PRCPAG","VO",VDA))
if ORDER=""
SET ORDER="<< UNABLE TO CREATE ORDER >>"
DO H
+8 SET GNM=""
FOR
SET GNM=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM,VDA,GNM))
if GNM=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+9 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
+10 WRITE !!?12,"GROUP CATEGORY: ",$SELECT(GNM=" ":"<< NOT SPECIFIED >>",1:GNM)
+11 SET DESCNSN=""
FOR
SET DESCNSN=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM,VDA,GNM,DESCNSN))
if DESCNSN=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:3
+12 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM,VDA,GNM,DESCNSN,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
SET D=^(ITEMDA)
Begin DoDot:4
+13 SET %=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
+14 SET ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+15 IF PRCP("DPTYPE")="W"
Begin DoDot:5
+16 WRITE !!,ITEMDA,?7
if PRCP("DPTYPE")'="W"
WRITE $EXTRACT(%,1,35)
if PRCP("DPTYPE")="W"
WRITE $EXTRACT(%,1,20),?31,$$NSN^PRCPUX1(ITEMDA)
WRITE ?50,$JUSTIFY($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),9),$JUSTIFY($PIECE(D,"^",12),9),$JUSTIFY($PIECE(D,"^",15),6),$JUSTIFY($PIECE(D,"^",16),6)
End DoDot:5
+17 IF PRCP("DPTYPE")'="W"
Begin DoDot:5
+18 WRITE !!,ITEMDA
+19 IF ODITEM="Y"
WRITE ?8,"D "
+20 IF ODITEM'="Y"
WRITE ?8," "
+21 if PRCP("DPTYPE")'="W"
WRITE $EXTRACT(%,1,32)
if PRCP("DPTYPE")="W"
WRITE $EXTRACT(%,1,17)
End DoDot:5
+22 WRITE ?31,$$NSN^PRCPUX1(ITEMDA)
WRITE ?50,$JUSTIFY($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),9),$JUSTIFY($PIECE(D,"^",12),9),$JUSTIFY($PIECE(D,"^",15),6),$JUSTIFY($PIECE(D,"^",16),6)
+23 WRITE !,$JUSTIFY("ONHAND",8),$JUSTIFY("+DUEIN",8),$JUSTIFY("-DUEOUT",8),$JUSTIFY("=AVAIL",8),$JUSTIFY("STAND",7),$JUSTIFY("OPTN",8),$JUSTIFY("LEVEL",8),$JUSTIFY("CONV",7),$JUSTIFY("ORDER",8),$JUSTIFY("UNIT$",
10)
+24 WRITE !,$JUSTIFY(+$PIECE(D,"^"),8),$JUSTIFY(+$PIECE(D,"^",2),8),$JUSTIFY(+$PIECE(D,"^",3),8),$JUSTIFY(+$PIECE(D,"^",4),8),$JUSTIFY(+$PIECE(D,"^",5),7),$SELECT($PIECE(D,"^",7)="STA":"*",1:" "),$JUSTIFY(+$PIECE(
D,"^",6),7),...
... $SELECT($PIECE(D,"^",7)="OPT":"*",1:" ")
+25 WRITE $JUSTIFY(+$PIECE(D,"^",8),7),$SELECT($PIECE(D,"^",9)="*":"*",1:" "),$JUSTIFY(+$PIECE(D,"^",10),6),$JUSTIFY(+$PIECE(D,"^",11),8),$JUSTIFY(+$PIECE(D,"^",14),10,3)
+26 SET TOTCOST=TOTCOST+$JUSTIFY($PIECE(D,"^",11)*$PIECE(D,"^",14),0,2)
+27 IF $Y>(IOSL-9)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
WRITE !!?12,"GROUP CATEGORY: ",$SELECT(GNM=" ":"<< NOT SPECIFIED >>",1:GNM)
End DoDot:4
End DoDot:3
End DoDot:2
+28 IF $GET(PRCPFLAG)
QUIT
+29 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
+30 WRITE !!,"TOTAL COST OF ORDER: ",TOTCOST
End DoDot:1
+31 IF $GET(PRCPFLAG)
QUIT
+32 DO END^PRCPUREP
+33 QUIT
+34 ;
+35 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"AUTO-GEN: SUGGESTED ORDERS FOR ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
+2 WRITE !?5,"ORDERING FROM ",$SELECT(PRCP("DPTYPE")="S":"PRIMARY INVENTORY POINT",1:"VENDOR"),": ",VNM
+3 WRITE !?5,$SELECT(PRCP("DPTYPE")="S":"DISTRIBUTION ORDER",1:"REPETITIVE ITEM LIST")," NUMBER: ",ORDER
+4 WRITE !?50,$JUSTIFY($SELECT(PRCP("DPTYPE")="S":"SECONDARY",PRCP("DPTYPE")="P":"PRIMARY",1:"WHSE"),9),$JUSTIFY($SELECT(PRCP("DPTYPE")="S":"PRIMARY",1:"VENDOR"),9),$JUSTIFY("ISSUE",6),$JUSTIFY("ISSUE",6)
+5 WRITE !,"IM#"
+6 IF PRCP("DPTYPE")="W"
Begin DoDot:1
+7 WRITE ?7,"DESCRIPTION"
End DoDot:1
+8 IF PRCP("DPTYPE")'="W"
Begin DoDot:1
+9 WRITE ?8,"OD",?11,"DESCRIPTION"
End DoDot:1
+10 if PRCP("DPTYPE")
WRITE ?31,"NSN"
WRITE ?50,$JUSTIFY("UNIT/ISS",9),$JUSTIFY("UNIT/ISS",9),$JUSTIFY("MINIM",6),$JUSTIFY("MULT",6)
+11 SET %=""
SET $PIECE(%,"-",81)=""
WRITE !,%
+12 QUIT
