PRCPRUSP ;WISC/RFJ/VAC-usage demand item report (print report) ; 3/6/07 9:00am
V ;;5.1;IFCAP;**1,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
;
;
PRINT ; print report
D NOW^%DTC S Y=% D DD^%DT S NOW=Y
S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
;
; whse
I PRCP("DPTYPE")="W" D
. S NSN=""
. F S NSN=$O(^TMP($J,"PRCPRUSE",NSN)) Q:NSN="" D Q:$D(PRCPFLAG)
. . S DESCR=0
. . F S DESCR=$O(^TMP($J,"PRCPRUSE",NSN,DESCR)) Q:DESCR']"" D Q:$D(PRCPFLAG)
. . . S ITEMDA=0
. . . F S ITEMDA=$O(^TMP($J,"PRCPRUSE",NSN,DESCR,ITEMDA)) Q:'ITEMDA D Q:$D(PRCPFLAG)
. . . . S DATA=^TMP($J,"PRCPRUSE",NSN,DESCR,ITEMDA)
. . . . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
. . . . I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . . . W !,$TR(NSN,"-"),?15,$E($P(DATA,"^"),1,15)
. . . . D USAGE
. . . . Q:$D(PRCPFLAG)
;
Q:$D(PRCPFLAG)
; primary and secondary
I PRCP("DPTYPE")'="W" D
. S GROUP=""
. F S GROUP=$O(^TMP($J,"PRCPRUSE",GROUP)) Q:GROUP="" D Q:$D(PRCPFLAG)
. . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
. . Q:$D(PRCPFLAG)
. . I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . W !!?5,"GROUP: ",$S(GROUP=" ":"<<NONE>>",1:GROUP)
. . S DESCR=""
. . F S DESCR=$O(^TMP($J,"PRCPRUSE",GROUP,DESCR)) Q:DESCR="" D Q:$D(PRCPFLAG)
. . . S ITEMDA=0
. . . F S ITEMDA=$O(^TMP($J,"PRCPRUSE",GROUP,DESCR,ITEMDA)) Q:'ITEMDA D Q:$D(PRCPFLAG)
. . . . S DATA=^TMP($J,"PRCPRUSE",GROUP,DESCR,ITEMDA)
. . . . S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
. . . . Q:ODITEM="Y"&(ODIFLG=1)
. . . . Q:ODITEM=""&(ODIFLG=2)
. . . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . . . W !,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,25)
. . . . D USAGE
. . . . Q:$D(PRCPFLAG)
. . . Q:$D(PRCPFLAG)
. . Q:$D(PRCPFLAG)
. Q:$D(PRCPFLAG)
;
I '$D(PRCPFLAG) D END^PRCPUREP
K ^TMP($J,"PRCPRUSE"),^TMP($J,"PRCPURS1")
D ^%ZISC
Q
;
;
USAGE ; display usage
I PRCP("DPTYPE")="W" D
.W ?31,ITEMDA
.W ?38,$J($P(DATA,"^",2),8)
.W $J($P(DATA,"^",3),12,3)
.W $J($P(DATA,"^",4),12,3)
.W $J($P(DATA,"^",5),9)
I PRCP("DPTYPE")'="W" D
.S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
.W ?27,ITEMDA
.I ODITEM="Y" W ?35,"D"
.W ?38,$J($P(DATA,"^",2),8)
.W ?47,$J($P(DATA,"^",3),12,3)
.W $J($P(DATA,"^",4),12,3)
.W $J($P(DATA,"^",5),9),!
.I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H W !
.S REORDER=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
.W ?4,"NORM: ",$P(REORDER,"^",9)
.W ?26,"REORD: ",$P(REORDER,"^",10)
.W ?48,"OPT: ",$P(REORDER,"^",4)
.W ?67,"EMER: ",$P(REORDER,"^",11)
.I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
Q:$D(PRCPFLAG)
S (COLUMN,TOTUSED,TOTCOST,TTOTUSED,TTOTCOST)=0
S DATE=$E(DATESTRT,1,5)-1
F S DATE=DATE+1 S:$E(DATE,4,5)=13 DATE=($E(DATE,1,3)+1)_"01" Q:DATE>$E(DATEEND,1,5)!($D(PRCPFLAG)) D
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. S DATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE,0))
. S MONYR=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(DATE,4,5))_$E(DATE,2,3)
. S TOTUSED=TOTUSED+$P(DATA,"^",2),TOTCOST=TOTCOST+$P(DATA,"^",3)
. S COLUMN=COLUMN+1
. W:COLUMN=1 !?4 W:COLUMN=2 ?31 W:COLUMN=3 ?58
. W MONYR,$J(+$P(DATA,"^",2),7),$J(+$P(DATA,"^",3),10,2)
. I COLUMN=3 S COLUMN=0
Q:$D(PRCPFLAG)
S TTOTUSED=TTOTUSED+TOTUSED,TTOTCOST=TTOTCOST+TOTCOST
W !?4,"---------------------------------------- CUMULATIVE TOTAL"
W ?63,$J(TTOTUSED,7),$J(TTOTCOST,10,2),!
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"USAGE DEMAND ITEM REPORT: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
S %="",$P(%,"-",81)=""
W !?5,"USAGE DATE RANGE FROM ",DATESTRD," TO ",DATEENDD," (",TOTALDAY," DAYS)"
I PRCP("DPTYPE")'="W" D
.I ODIFLG=1 W !,?5,"STANDARD ITEMS ONLY"
.I ODIFLG=2 W !,?5,"ON-DEMAND ITEMS ONLY"
.I ODIFLG=3 W !,?5,"ALL ITEMS (STANDARD AND ON-DEMAND)"
I PRCP("DPTYPE")="W" W !,"NSN",?15,"DESCRIPTION"
E W !,"DESCRIPTION"
I PRCP("DPTYPE")'="W" D
. W ?27,"IM",?35,"OD",?40,"UNIT/IS",?53,"LAST $",?66,"AVG $",?73,"ON-HAND",!,%
I PRCP("DPTYPE")="W" D
. W ?31,"IM",?38,$J("UNIT/IS",8),$J("LAST $",12),$J("AVG $",12),$J("ON-HAND",9),!,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRUSP 4418 printed Apr 09, 2024@21:15:07 Page 2
PRCPRUSP ;WISC/RFJ/VAC-usage demand item report (print report) ; 3/6/07 9:00am
V ;;5.1;IFCAP;**1,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 QUIT
+4 ;
+5 ;
PRINT ; print report
+1 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
+2 SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+3 ;
+4 ; whse
+5 IF PRCP("DPTYPE")="W"
Begin DoDot:1
+6 SET NSN=""
+7 FOR
SET NSN=$ORDER(^TMP($JOB,"PRCPRUSE",NSN))
if NSN=""
QUIT
Begin DoDot:2
+8 SET DESCR=0
+9 FOR
SET DESCR=$ORDER(^TMP($JOB,"PRCPRUSE",NSN,DESCR))
if DESCR']""
QUIT
Begin DoDot:3
+10 SET ITEMDA=0
+11 FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRUSE",NSN,DESCR,ITEMDA))
if 'ITEMDA
QUIT
Begin DoDot:4
+12 SET DATA=^TMP($JOB,"PRCPRUSE",NSN,DESCR,ITEMDA)
+13 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
+14 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+15 WRITE !,$TRANSLATE(NSN,"-"),?15,$EXTRACT($PIECE(DATA,"^"),1,15)
+16 DO USAGE
+17 if $DATA(PRCPFLAG)
QUIT
End DoDot:4
if $DATA(PRCPFLAG)
QUIT
End DoDot:3
if $DATA(PRCPFLAG)
QUIT
End DoDot:2
if $DATA(PRCPFLAG)
QUIT
End DoDot:1
+18 ;
+19 if $DATA(PRCPFLAG)
QUIT
+20 ; primary and secondary
+21 IF PRCP("DPTYPE")'="W"
Begin DoDot:1
+22 SET GROUP=""
+23 FOR
SET GROUP=$ORDER(^TMP($JOB,"PRCPRUSE",GROUP))
if GROUP=""
QUIT
Begin DoDot:2
+24 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
+25 if $DATA(PRCPFLAG)
QUIT
+26 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+27 WRITE !!?5,"GROUP: ",$SELECT(GROUP=" ":"<<NONE>>",1:GROUP)
+28 SET DESCR=""
+29 FOR
SET DESCR=$ORDER(^TMP($JOB,"PRCPRUSE",GROUP,DESCR))
if DESCR=""
QUIT
Begin DoDot:3
+30 SET ITEMDA=0
+31 FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRUSE",GROUP,DESCR,ITEMDA))
if 'ITEMDA
QUIT
Begin DoDot:4
+32 SET DATA=^TMP($JOB,"PRCPRUSE",GROUP,DESCR,ITEMDA)
+33 SET ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+34 if ODITEM="Y"&(ODIFLG=1)
QUIT
+35 if ODITEM=""&(ODIFLG=2)
QUIT
+36 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+37 WRITE !,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,25)
+38 DO USAGE
+39 if $DATA(PRCPFLAG)
QUIT
End DoDot:4
if $DATA(PRCPFLAG)
QUIT
+40 if $DATA(PRCPFLAG)
QUIT
End DoDot:3
if $DATA(PRCPFLAG)
QUIT
+41 if $DATA(PRCPFLAG)
QUIT
End DoDot:2
if $DATA(PRCPFLAG)
QUIT
+42 if $DATA(PRCPFLAG)
QUIT
End DoDot:1
+43 ;
+44 IF '$DATA(PRCPFLAG)
DO END^PRCPUREP
+45 KILL ^TMP($JOB,"PRCPRUSE"),^TMP($JOB,"PRCPURS1")
+46 DO ^%ZISC
+47 QUIT
+48 ;
+49 ;
USAGE ; display usage
+1 IF PRCP("DPTYPE")="W"
Begin DoDot:1
+2 WRITE ?31,ITEMDA
+3 WRITE ?38,$JUSTIFY($PIECE(DATA,"^",2),8)
+4 WRITE $JUSTIFY($PIECE(DATA,"^",3),12,3)
+5 WRITE $JUSTIFY($PIECE(DATA,"^",4),12,3)
+6 WRITE $JUSTIFY($PIECE(DATA,"^",5),9)
End DoDot:1
+7 IF PRCP("DPTYPE")'="W"
Begin DoDot:1
+8 SET ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+9 WRITE ?27,ITEMDA
+10 IF ODITEM="Y"
WRITE ?35,"D"
+11 WRITE ?38,$JUSTIFY($PIECE(DATA,"^",2),8)
+12 WRITE ?47,$JUSTIFY($PIECE(DATA,"^",3),12,3)
+13 WRITE $JUSTIFY($PIECE(DATA,"^",4),12,3)
+14 WRITE $JUSTIFY($PIECE(DATA,"^",5),9),!
+15 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
WRITE !
+16 SET REORDER=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
+17 WRITE ?4,"NORM: ",$PIECE(REORDER,"^",9)
+18 WRITE ?26,"REORD: ",$PIECE(REORDER,"^",10)
+19 WRITE ?48,"OPT: ",$PIECE(REORDER,"^",4)
+20 WRITE ?67,"EMER: ",$PIECE(REORDER,"^",11)
+21 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:1
+22 if $DATA(PRCPFLAG)
QUIT
+23 SET (COLUMN,TOTUSED,TOTCOST,TTOTUSED,TTOTCOST)=0
+24 SET DATE=$EXTRACT(DATESTRT,1,5)-1
+25 FOR
SET DATE=DATE+1
if $EXTRACT(DATE,4,5)=13
SET DATE=($EXTRACT(DATE,1,3)+1)_"01"
if DATE>$EXTRACT(DATEEND,1,5)!($DATA(PRCPFLAG))
QUIT
Begin DoDot:1
+26 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+27 SET DATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE,0))
+28 SET MONYR=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(DATE,4,5))_$EXTRACT(DATE,2,3)
+29 SET TOTUSED=TOTUSED+$PIECE(DATA,"^",2)
SET TOTCOST=TOTCOST+$PIECE(DATA,"^",3)
+30 SET COLUMN=COLUMN+1
+31 if COLUMN=1
WRITE !?4
if COLUMN=2
WRITE ?31
if COLUMN=3
WRITE ?58
+32 WRITE MONYR,$JUSTIFY(+$PIECE(DATA,"^",2),7),$JUSTIFY(+$PIECE(DATA,"^",3),10,2)
+33 IF COLUMN=3
SET COLUMN=0
End DoDot:1
+34 if $DATA(PRCPFLAG)
QUIT
+35 SET TTOTUSED=TTOTUSED+TOTUSED
SET TTOTCOST=TTOTCOST+TOTCOST
+36 WRITE !?4,"---------------------------------------- CUMULATIVE TOTAL"
+37 WRITE ?63,$JUSTIFY(TTOTUSED,7),$JUSTIFY(TTOTCOST,10,2),!
+38 QUIT
+39 ;
+40 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"USAGE DEMAND ITEM REPORT: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
+2 SET %=""
SET $PIECE(%,"-",81)=""
+3 WRITE !?5,"USAGE DATE RANGE FROM ",DATESTRD," TO ",DATEENDD," (",TOTALDAY," DAYS)"
+4 IF PRCP("DPTYPE")'="W"
Begin DoDot:1
+5 IF ODIFLG=1
WRITE !,?5,"STANDARD ITEMS ONLY"
+6 IF ODIFLG=2
WRITE !,?5,"ON-DEMAND ITEMS ONLY"
+7 IF ODIFLG=3
WRITE !,?5,"ALL ITEMS (STANDARD AND ON-DEMAND)"
End DoDot:1
+8 IF PRCP("DPTYPE")="W"
WRITE !,"NSN",?15,"DESCRIPTION"
+9 IF '$TEST
WRITE !,"DESCRIPTION"
+10 IF PRCP("DPTYPE")'="W"
Begin DoDot:1
+11 WRITE ?27,"IM",?35,"OD",?40,"UNIT/IS",?53,"LAST $",?66,"AVG $",?73,"ON-HAND",!,%
End DoDot:1
+12 IF PRCP("DPTYPE")="W"
Begin DoDot:1
+13 WRITE ?31,"IM",?38,$JUSTIFY("UNIT/IS",8),$JUSTIFY("LAST $",12),$JUSTIFY("AVG $",12),$JUSTIFY("ON-HAND",9),!,%
End DoDot:1
+14 QUIT
