- 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 Mar 13, 2025@21:17:26 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
