- 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 Mar 13, 2025@21:20:27 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
