- 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 Mar 13, 2025@21:19:46 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
