PRCPRINV ;WISC/RFJ/DGL/VAC-inventory control parameters report ; 2/27/07 8:46am
V ;;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.
;*98 Modified for Total = ODI+Standard, rather than pull from 0 node
D ^PRCPUSEL Q:'$G(PRCP("I"))
N PRCPINPT,X,POP,ZTDESC,ZTRTN,ZTSAVE
I "WP"[PRCP("DPTYPE") W !!,"--Press RETURN to print parameters for ",PRCP("IN"),"--" S PRCPINPT=$$TO^PRCPUDPT(PRCP("I")) I PRCPINPT["^" Q
I '$G(PRCPINPT) S PRCPINPT=PRCP("I")
W !!,"Print control parameters for ",$$INVNAME^PRCPUX1(PRCPINPT),!
S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
. S ZTDESC="Inventory Parameters",ZTRTN="DQ^PRCPRINV"
. S ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ; queue starts here
N %,%I,DATA,DISTR,FCP,ITEMCTR,MGRFLG,NOW,ODIFLG,ODITEM,PAGE,PRCPFLAG,PRCPNAME,PRCPTYPE,SCREEN,SECT,STATION,STDITEM,USER,X,Y
S DATA=$G(^PRCP(445,PRCPINPT,0)),PRCPNAME=$P(DATA,"^"),PRCPTYPE=$P(DATA,"^",3)
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
W !!,"TYPE OF INVENTORY POINT",?30,": ",$S(PRCPTYPE="W":"SUPPLY WAREHOUSE",PRCPTYPE="P":"PRIMARY",PRCPTYPE="S":"SECONDARY",1:"<<NOT DEFINED>>")
W !,"ABBREVIATED NAME",?30,": ",$P(DATA,"^",5)
I PRCPTYPE="W"!(PRCPTYPE="P") W !,"COST CENTER",?30,": ",$E($P($G(^PRCD(420.1,+$P(DATA,"^",7),0)),"^"),1,48)
W !,"KEEP PERPETUAL INVENTORY",?30,": ",$S($P(DATA,"^",2)="Y":"YES",1:"NO")
W !,"KEEP TRANSACTION/USAGE HISTORY",?30,": ",$S($P(DATA,"^",6)="Y":"YES",1:"NO")
I $Y>(IOSL-7) D:SCREEN P^PRCPUREP G:$D(PRCPFLAG) Q D H
I PRCPTYPE="P" D
. W !,"PRIMARY UPDATED BY WAREHOUSE",?30,": ",$S($P(DATA,"^",16)="N":"NO",1:"YES")
. W !,"SPECIAL INVENTORY POINT TYPE",?30,": ",$S($P(DATA,"^",20)="D":"DRUG ACCOUNTABILITY",$P(DATA,"^",20)="S":"SPD",1:"")
. I $P(DATA,"^",20)="S" W !,"SPD PICKING TICKET PRINTER: ",$P($G(^PRCP(445,PRCPINPT,"DEV")),"^")
. W !,"ISSUE BOOK SORT",?30,": ",$S($P(DATA,"^",10)="A":"ALPHA SORT",$P(DATA,"^",10)="N":"NSN SORT",1:"")
. W !,"REGULAR WHSE ISSUES SCHEDULE",?30,": ",$S($P(DATA,"^",4)="W":"WEEKLY",$P(DATA,"^",4)=2:"EVERY 2 WEEKS",$P(DATA,"^",4)="M":"MONTHLY",$P(DATA,"^",4)="O":"OTHER",1:"")
. W !,"DEPARTMENT NUMBER",?30,": ",$P(DATA,"^",8)
W !,"MONTHS INACTIVE ITEM DELETION",?30,": ",$P(DATA,"^",13)
;Count number of on-demand and standard items
S (ODITEM,STDITEM,ITEMCTR)=0
F S ITEMCTR=$O(^PRCP(445,PRCPINPT,1,ITEMCTR)) Q:+ITEMCTR=0 D
.S ODIFLG=$$ODITEM^PRCPUX2(PRCPINPT,ITEMCTR)
.I ODIFLG="Y" S ODITEM=ODITEM+1 Q
.S STDITEM=STDITEM+1
I PRCPTYPE'="W" D
.W !,"TOTAL STANDARD ITEMS",?30,": ",STDITEM
.I $Y>(IOSL-6) D:SCREEN P^PRCPUREP G:$D(PRCPFLAG) Q D H
.W !,"TOTAL ON-DEMAND ITEMS",?30,": ",ODITEM
.I $Y>(IOSL-6) D:SCREEN P^PRCPUREP G:$D(PRCPFLAG) Q D H
; the following line was re-written with patch PRC*5.1*98
;W !,"TOTAL NUMBER OF ITEMS STORED",?30,": ",+$P($G(^PRCP(445,PRCPINPT,1,0)),"^",4)
W !,"TOTAL NUMBER OF ITEMS STORED",?30,": ",STDITEM+ODITEM
I $Y>(IOSL-6) D:SCREEN P^PRCPUREP G:$D(PRCPFLAG) Q D H
I PRCPTYPE="W"!(PRCPTYPE="P") D
. W !!,"FUND CONTROL POINTS",?30,": "
. S STATION=0 F S STATION=$O(^PRC(420,"AE",STATION)) Q:'STATION!($G(PRCPFLAG)) S FCP=0 F S FCP=$O(^PRC(420,"AE",STATION,PRCPINPT,FCP)) Q:'FCP!($G(PRCPFLAG)) D
. . W $P($G(^PRC(420,STATION,1,FCP,0)),"^")
. . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . W !?32
I $G(PRCPFLAG) D Q Q
I $Y>(IOSL-6) D:SCREEN P^PRCPUREP G:$D(PRCPFLAG) Q D H
I PRCPTYPE="S"!(PRCPTYPE="P") D
. W !!,"MIS COSTING SECTION",?30,": "
. S SECT=0 F S SECT=$O(^PRCP(445,PRCPINPT,3,SECT)) Q:'SECT!($G(PRCPFLAG)) D
. . S %=$G(^PRCP(445,PRCPINPT,3,SECT,0))
. . W $E($P($G(^DIC(49,+$P(%,"^"),0)),"^"),1,30),?64,$J($P(%,"^",2),5)," %"
. . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . W !?32
I $G(PRCPFLAG) D Q Q
I $Y>(IOSL-6) D:SCREEN P^PRCPUREP G:$D(PRCPFLAG) Q D H
W !!,"INVENTORY USERS",?30,": "
S USER=0 F S USER=$O(^PRCP(445,PRCPINPT,4,USER)) Q:'USER!($G(PRCPFLAG)) D
. S MGRFLG=""
. W $E($$USER^PRCPUREP(USER),1,30)
. I $$KEY^PRCPUREP("PRCP"_$S(PRCPTYPE="P":"",PRCPTYPE="W":"W",PRCPTYPE="S":"2",1:"?")_" MGRKEY",USER) S MGRFLG="**MANAGER**"
. I $D(^PRCP(445,PRCPINPT,9,USER,0)) S MGRFLG="**ODI MGR**"
. W ?64,MGRFLG
. I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. W !?32
I $G(PRCPFLAG) D Q Q
I $Y>(IOSL-6) D:SCREEN P^PRCPUREP G:$D(PRCPFLAG) Q D H
I PRCPTYPE="W"!(PRCPTYPE="P") D
. W !!,"DISTRIBUTION POINTS",?30,": "
. S DISTR=0 F S DISTR=$O(^PRCP(445,PRCPINPT,2,DISTR)) Q:'DISTR!($G(PRCPFLAG)) D
. . S %=$P($G(^PRCP(445,DISTR,0)),"^",3)
. . W $$INVNAME^PRCPUX1(DISTR),?64,$S(%="W":"SUPPLY WAREHOUSE",%="P":"PRIMARY",%="S":"SECONDARY",1:"<<NOT DEFINED>>")
. . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . W !?32
I '$G(PRCPFLAG) D END^PRCPUREP
Q D ^%ZISC
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"INVENTORY PARAMETERS FOR: ",$E(PRCPNAME,1,20),?(80-$L(%)),%
S %="",$P(%,"-",81)=""
W !,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRINV 5234 printed Sep 23, 2025@19:51:04 Page 2
PRCPRINV ;WISC/RFJ/DGL/VAC-inventory control parameters report ; 2/27/07 8:46am
V ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;*98 Modified to accommodate On-Demand Items.
+3 ;*98 Modified for Total = ODI+Standard, rather than pull from 0 node
+4 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+5 NEW PRCPINPT,X,POP,ZTDESC,ZTRTN,ZTSAVE
+6 IF "WP"[PRCP("DPTYPE")
WRITE !!,"--Press RETURN to print parameters for ",PRCP("IN"),"--"
SET PRCPINPT=$$TO^PRCPUDPT(PRCP("I"))
IF PRCPINPT["^"
QUIT
+7 IF '$GET(PRCPINPT)
SET PRCPINPT=PRCP("I")
+8 WRITE !!,"Print control parameters for ",$$INVNAME^PRCPUX1(PRCPINPT),!
+9 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTDESC="Inventory Parameters"
SET ZTRTN="DQ^PRCPRINV"
+11 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+12 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW %,%I,DATA,DISTR,FCP,ITEMCTR,MGRFLG,NOW,ODIFLG,ODITEM,PAGE,PRCPFLAG,PRCPNAME,PRCPTYPE,SCREEN,SECT,STATION,STDITEM,USER,X,Y
+2 SET DATA=$GET(^PRCP(445,PRCPINPT,0))
SET PRCPNAME=$PIECE(DATA,"^")
SET PRCPTYPE=$PIECE(DATA,"^",3)
+3 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+4 WRITE !!,"TYPE OF INVENTORY POINT",?30,": ",$SELECT(PRCPTYPE="W":"SUPPLY WAREHOUSE",PRCPTYPE="P":"PRIMARY",PRCPTYPE="S":"SECONDARY",1:"<<NOT DEFINED>>")
+5 WRITE !,"ABBREVIATED NAME",?30,": ",$PIECE(DATA,"^",5)
+6 IF PRCPTYPE="W"!(PRCPTYPE="P")
WRITE !,"COST CENTER",?30,": ",$EXTRACT($PIECE($GET(^PRCD(420.1,+$PIECE(DATA,"^",7),0)),"^"),1,48)
+7 WRITE !,"KEEP PERPETUAL INVENTORY",?30,": ",$SELECT($PIECE(DATA,"^",2)="Y":"YES",1:"NO")
+8 WRITE !,"KEEP TRANSACTION/USAGE HISTORY",?30,": ",$SELECT($PIECE(DATA,"^",6)="Y":"YES",1:"NO")
+9 IF $Y>(IOSL-7)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
GOTO Q
DO H
+10 IF PRCPTYPE="P"
Begin DoDot:1
+11 WRITE !,"PRIMARY UPDATED BY WAREHOUSE",?30,": ",$SELECT($PIECE(DATA,"^",16)="N":"NO",1:"YES")
+12 WRITE !,"SPECIAL INVENTORY POINT TYPE",?30,": ",$SELECT($PIECE(DATA,"^",20)="D":"DRUG ACCOUNTABILITY",$PIECE(DATA,"^",20)="S":"SPD",1:"")
+13 IF $PIECE(DATA,"^",20)="S"
WRITE !,"SPD PICKING TICKET PRINTER: ",$PIECE($GET(^PRCP(445,PRCPINPT,"DEV")),"^")
+14 WRITE !,"ISSUE BOOK SORT",?30,": ",$SELECT($PIECE(DATA,"^",10)="A":"ALPHA SORT",$PIECE(DATA,"^",10)="N":"NSN SORT",1:"")
+15 WRITE !,"REGULAR WHSE ISSUES SCHEDULE",?30,": ",$SELECT($PIECE(DATA,"^",4)="W":"WEEKLY",$PIECE(DATA,"^",4)=2:"EVERY 2 WEEKS",$PIECE(DATA,"^",4)="M":"MONTHLY",$PIECE(DATA,"^",4)="O":"OTHER",1:"")
+16 WRITE !,"DEPARTMENT NUMBER",?30,": ",$PIECE(DATA,"^",8)
End DoDot:1
+17 WRITE !,"MONTHS INACTIVE ITEM DELETION",?30,": ",$PIECE(DATA,"^",13)
+18 ;Count number of on-demand and standard items
+19 SET (ODITEM,STDITEM,ITEMCTR)=0
+20 FOR
SET ITEMCTR=$ORDER(^PRCP(445,PRCPINPT,1,ITEMCTR))
if +ITEMCTR=0
QUIT
Begin DoDot:1
+21 SET ODIFLG=$$ODITEM^PRCPUX2(PRCPINPT,ITEMCTR)
+22 IF ODIFLG="Y"
SET ODITEM=ODITEM+1
QUIT
+23 SET STDITEM=STDITEM+1
End DoDot:1
+24 IF PRCPTYPE'="W"
Begin DoDot:1
+25 WRITE !,"TOTAL STANDARD ITEMS",?30,": ",STDITEM
+26 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
GOTO Q
DO H
+27 WRITE !,"TOTAL ON-DEMAND ITEMS",?30,": ",ODITEM
+28 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
GOTO Q
DO H
End DoDot:1
+29 ; the following line was re-written with patch PRC*5.1*98
+30 ;W !,"TOTAL NUMBER OF ITEMS STORED",?30,": ",+$P($G(^PRCP(445,PRCPINPT,1,0)),"^",4)
+31 WRITE !,"TOTAL NUMBER OF ITEMS STORED",?30,": ",STDITEM+ODITEM
+32 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
GOTO Q
DO H
+33 IF PRCPTYPE="W"!(PRCPTYPE="P")
Begin DoDot:1
+34 WRITE !!,"FUND CONTROL POINTS",?30,": "
+35 SET STATION=0
FOR
SET STATION=$ORDER(^PRC(420,"AE",STATION))
if 'STATION!($GET(PRCPFLAG))
QUIT
SET FCP=0
FOR
SET FCP=$ORDER(^PRC(420,"AE",STATION,PRCPINPT,FCP))
if 'FCP!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+36 WRITE $PIECE($GET(^PRC(420,STATION,1,FCP,0)),"^")
+37 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+38 WRITE !?32
End DoDot:2
End DoDot:1
+39 IF $GET(PRCPFLAG)
DO Q
QUIT
+40 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
GOTO Q
DO H
+41 IF PRCPTYPE="S"!(PRCPTYPE="P")
Begin DoDot:1
+42 WRITE !!,"MIS COSTING SECTION",?30,": "
+43 SET SECT=0
FOR
SET SECT=$ORDER(^PRCP(445,PRCPINPT,3,SECT))
if 'SECT!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+44 SET %=$GET(^PRCP(445,PRCPINPT,3,SECT,0))
+45 WRITE $EXTRACT($PIECE($GET(^DIC(49,+$PIECE(%,"^"),0)),"^"),1,30),?64,$JUSTIFY($PIECE(%,"^",2),5)," %"
+46 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+47 WRITE !?32
End DoDot:2
End DoDot:1
+48 IF $GET(PRCPFLAG)
DO Q
QUIT
+49 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
GOTO Q
DO H
+50 WRITE !!,"INVENTORY USERS",?30,": "
+51 SET USER=0
FOR
SET USER=$ORDER(^PRCP(445,PRCPINPT,4,USER))
if 'USER!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+52 SET MGRFLG=""
+53 WRITE $EXTRACT($$USER^PRCPUREP(USER),1,30)
+54 IF $$KEY^PRCPUREP("PRCP"_$SELECT(PRCPTYPE="P":"",PRCPTYPE="W":"W",PRCPTYPE="S":"2",1:"?")_" MGRKEY",USER)
SET MGRFLG="**MANAGER**"
+55 IF $DATA(^PRCP(445,PRCPINPT,9,USER,0))
SET MGRFLG="**ODI MGR**"
+56 WRITE ?64,MGRFLG
+57 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+58 WRITE !?32
End DoDot:1
+59 IF $GET(PRCPFLAG)
DO Q
QUIT
+60 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
GOTO Q
DO H
+61 IF PRCPTYPE="W"!(PRCPTYPE="P")
Begin DoDot:1
+62 WRITE !!,"DISTRIBUTION POINTS",?30,": "
+63 SET DISTR=0
FOR
SET DISTR=$ORDER(^PRCP(445,PRCPINPT,2,DISTR))
if 'DISTR!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+64 SET %=$PIECE($GET(^PRCP(445,DISTR,0)),"^",3)
+65 WRITE $$INVNAME^PRCPUX1(DISTR),?64,$SELECT(%="W":"SUPPLY WAREHOUSE",%="P":"PRIMARY",%="S":"SECONDARY",1:"<<NOT DEFINED>>")
+66 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+67 WRITE !?32
End DoDot:2
End DoDot:1
+68 IF '$GET(PRCPFLAG)
DO END^PRCPUREP
Q DO ^%ZISC
+1 QUIT
+2 ;
+3 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"INVENTORY PARAMETERS FOR: ",$EXTRACT(PRCPNAME,1,20),?(80-$LENGTH(%)),%
+2 SET %=""
SET $PIECE(%,"-",81)=""
+3 WRITE !,%
+4 QUIT
