PRCPRUS2 ;WISC/VAC-usage increase,decrease usage report ; 11/29/06 2:04pm
V ;;5.1;IFCAP;**98,228** ; Oct 20, 2000;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*228 Correct requested time period calculation
;
;This routine is called from PRCPRUS1 and was modified to work only
; with Primary and Secondary inventory points. To call this
; directly, first run ^PRCPUSEL to set location points
N %,AVERAGE,CHANGE,COMDATA,COMDT,COMPARE,DATA,DATE,DEFAULT,DESCR,END,ENDDT,ITEMDA,LASTMO,MAXDT,MONTHS,NOW,NOWDT,PAGE,PERCENT,PRCPEND,PRCPFLAG,REPTYPE,SCREEN,START,STARTDT,TOTAL,X,Y,Z
N DATA2,GROUP,GROUPALL,GROUPNM,ODIFLG,ORDER,SRT,TYPNUM,X1,X2
D NOW^%DTC S NOWDT=X,Y=% D DD^%DT S NOW=Y,X1=$E(NOWDT,1,5)_"15",X2=-30 D C^%DTC S (LASTMO,Y)=$E(X,1,5)_"00" D DD^%DT S DEFAULT=Y
S PRCPEND=$P("31^28^31^30^31^30^31^31^30^31^30^31","^",+$E(NOWDT,4,5))
I PRCPEND=28 S Z=$E(NOWDT,1,3)+1700,PRCPEND=$S(Z#400=0:29,(Z#4=0&(Z#100'=0)):29,1:28)
S MAXDT=$E(NOWDT,1,5)_PRCPEND,Y=($E(LASTMO,1,3)-1)_$E(LASTMO,4,5)_"00" D DD^%DT S START=Y
S %DT="AEP",%DT("A")="Compare Usage to Date (Month Year): ",%DT("B")=DEFAULT,%DT(0)=-MAXDT W ! D ^%DT K %DT Q:Y<0 S COMDT=$E(Y,1,5)
START S %DT="AEP",%DT("A")="Start Comparison Usage with Date (Month Year): ",%DT("B")=START,%DT(0)=-MAXDT W ! D ^%DT K %DT Q:Y<0 S STARTDT=$E(Y,1,5)
S %DT="AEP",%DT("A")=" End Comparison Usage with Date (Month Year): ",%DT("B")=DEFAULT,%DT(0)=-MAXDT D ^%DT K %DT Q:Y<0 S ENDDT=$E(Y,1,5)
I ENDDT<STARTDT W !,"END DATE MUST BE GREATER THAN OR EQUAL TO THE START DATE." G START
S DIR(0)="N^1:1000",DIR("A")="Enter the percentage of change",DIR("?",1)="Enter a whole number change between 1 and 1000 which represents the percentage",DIR("?")="between the average (from start to end month) and the compare month."
S DIR("B")=50 W ! D ^DIR K DIR Q:'+Y S PERCENT=+Y
S DIR(0)="S^D:Decrease in Usage;I:Increase in Usage",DIR("A")="Show Items with Increase or Decrease in Usage",DIR("B")="Decrease in Usage" W ! D ^DIR K DIR
S REPTYPE=$S(Y="D":"DECREASE",1:"INCREASE"),SCREEN=$S(Y="D":"I COMDATA<AVERAGE",Y="I":"I COMDATA>AVERAGE",1:"") Q:SCREEN=""
; Insert prompt for Group
K X S X(1)="Select the Group Categories to display" D DISPLAY^PRCPUX2(2,40,.X)
D GROUPSEL^PRCPURS1(PRCP("I"))
I '$G(GROUPALL),'$O(^TMP($J,"PRCPURS1","YES",0)) W !,"*** NO GROUP CATEGORIES SELECTED !" D Q Q
W !,"NOTE: The report will",$S('$G(GROUPALL):" NOT",1:"")," include items not stored in a group category."
; Insert prompt for Standard, ODI or both
S TYPNUM=$$ODIPROM^PRCPUX2(0)
Q:TYPNUM=0
DESC ; Insert prompt for sort order by item number or name
S SRT=$$SRTPRMP^PRCPUX2(0)
Q:SRT=0
I (+SRT<1)!(+SRT>2) G DESC
S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
. S ZTDESC="Usage Demand Analysis Report",ZTRTN="DQ^PRCPRUS2"
. S ZTSAVE("PRCP*")="",ZTSAVE("REPTYPE")="",ZTSAVE("S*")="",ZTSAVE("END*")="",ZTSAVE("NOW*")="",ZTSAVE("COMDT")="",ZTSAVE("PERCENT")="",ZTSAVE("REP")="",ZTSAVE("ZTREQ")="@",ZTSAVE("SCREEN")=""
. S ZTSAVE("GROUP*")="",ZTSAVE("^TMP($J,""PRCPURS1"",")="",ZTSAVE("TYP*")=""
W !!,"<*> please wait <*>"
DQ ;queue comes here
K ^TMP($J,"USAGE2") S X1=ENDDT_"00",X2=STARTDT_"00" D ^%DTC S MONTHS=(X+12)\30+1 S:'MONTHS MONTHS=1 ;PRC*5.1*228
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:+ITEMDA=0 D
. S DATA2=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)) Q:DATA2=""
. S GROUP=+$P(DATA2,"^",21)
. I 'GROUP,'$G(GROUPALL) Q
. I $G(GROUPALL),$D(^TMP($J,"PRCPURS1","NO",GROUP)) Q
. I '$G(GROUPALL),'$D(^TMP($J,"PRCPURS1","YES",GROUP)) Q
. S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
. I GROUPNM'="" S GROUPNM=$E(GROUPNM,1,20)_" (#"_GROUP_")"
. S:GROUPNM="" GROUPNM=" "
. I SRT=2 S ORDER=ITEMDA
. I SRT=1 D
.. S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
.. S DESCR=$E(DESCR,1,20)
.. S ORDER=DESCR
. S DATE=STARTDT-1,TOTAL=0 F S DATE=$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE)) Q:'DATE!(DATE>ENDDT) S TOTAL=TOTAL+$P($G(^(DATE,0)),"^",2)
. Q:TOTAL="" S AVERAGE=TOTAL/MONTHS,COMDATA=+$P($G(^PRCP(445,PRCP("I"),1,ITEMDA,2,COMDT,0)),"^",2) X SCREEN Q:'$T
. S CHANGE=$S(AVERAGE=0:"***.**",1:(COMDATA-AVERAGE)/AVERAGE*100) S:CHANGE<0 CHANGE=-CHANGE I CHANGE'["*",CHANGE<PERCENT Q
. S ^TMP($J,"USAGE2",GROUPNM,ORDER,ITEMDA)=COMDATA_"^"_$J(AVERAGE,0,2)_"^"_$S(CHANGE["*":CHANGE,1:$J(CHANGE,0,2))
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1
S Y=COMDT_"00" D DD^%DT S COMPARE=Y,Y=STARTDT_"00" D DD^%DT S START=Y,Y=ENDDT_"00" D DD^%DT S END=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
I $D(^TMP($J))=0 D END^PRCPUREP G Q
S GROUPNM="" F S GROUPNM=$O(^TMP($J,"USAGE2",GROUPNM)) Q:GROUPNM="" D
.Q:$D(PRCPFLAG)
. W !,?6,"GROUP: ",GROUPNM
. I GROUPNM=""!(GROUPNM=" ") W "<NONE>"
. W !
. I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. S ORDER="" F S ORDER=$O(^TMP($J,"USAGE2",GROUPNM,ORDER)) Q:ORDER="" D
.. Q:$D(PRCPFLAG)
.. S ITEMDA="" F S ITEMDA=$O(^TMP($J,"USAGE2",GROUPNM,ORDER,ITEMDA)) Q:ITEMDA="" D
... S ODIFLG=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
... I (TYPNUM=1)&(ODIFLG="Y") Q
... I (TYPNUM=2)&(ODIFLG'="Y") Q
... Q:$D(PRCPFLAG)
... S DATA=$G(^TMP($J,"USAGE2",GROUPNM,ORDER,ITEMDA))
... W !,ITEMDA
... S ODIFLG=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
... I ODIFLG="Y" W ?9,"D"
... W ?15,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,20),?41,$J($P(DATA,"^"),10),?55,$J($P(DATA,"^",2),10),?70,$J($P(DATA,"^",3),9)
... I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
... Q:$D(PRCPFLAG)
... I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
.. Q:$D(PRCPFLAG)
. Q:$D(PRCPFLAG)
. W !
D END^PRCPUREP
Q D ^%ZISC K ^TMP($J,"USAGE2"),^TMP($J,"PRCPURS1") Q
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"USAGE DEMAND ANALYSIS FOR: ",PRCP("IN"),?(80-$L(%)),%
W !?5,"AVERAGE USAGE FROM ",START," TO ",END," (",MONTHS," MONTHS)"
W !?5,"COMPARE USAGE WITH ",COMPARE,?40,"PERCENT ",REPTYPE," AT LEAST: ",PERCENT," %"
S %="",$P(%,"-",81)="" W !,"IM#",?8,"OD",?15,"DESCRIPTION",?41,"COMPARE QTY",?55,"AVERAGE QTY",?70,"% "_REPTYPE,!,% Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRUS2 6233 printed Sep 23, 2025@19:51:43 Page 2
PRCPRUS2 ;WISC/VAC-usage increase,decrease usage report ; 11/29/06 2:04pm
V ;;5.1;IFCAP;**98,228** ; Oct 20, 2000;Build 3
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*228 Correct requested time period calculation
+4 ;
+5 ;This routine is called from PRCPRUS1 and was modified to work only
+6 ; with Primary and Secondary inventory points. To call this
+7 ; directly, first run ^PRCPUSEL to set location points
+8 NEW %,AVERAGE,CHANGE,COMDATA,COMDT,COMPARE,DATA,DATE,DEFAULT,DESCR,END,ENDDT,ITEMDA,LASTMO,MAXDT,MONTHS,NOW,NOWDT,PAGE,PERCENT,PRCPEND,PRCPFLAG,REPTYPE,SCREEN,START,STARTDT,TOTAL,X,Y,Z
+9 NEW DATA2,GROUP,GROUPALL,GROUPNM,ODIFLG,ORDER,SRT,TYPNUM,X1,X2
+10 DO NOW^%DTC
SET NOWDT=X
SET Y=%
DO DD^%DT
SET NOW=Y
SET X1=$EXTRACT(NOWDT,1,5)_"15"
SET X2=-30
DO C^%DTC
SET (LASTMO,Y)=$EXTRACT(X,1,5)_"00"
DO DD^%DT
SET DEFAULT=Y
+11 SET PRCPEND=$PIECE("31^28^31^30^31^30^31^31^30^31^30^31","^",+$EXTRACT(NOWDT,4,5))
+12 IF PRCPEND=28
SET Z=$EXTRACT(NOWDT,1,3)+1700
SET PRCPEND=$SELECT(Z#400=0:29,(Z#4=0&(Z#100'=0)):29,1:28)
+13 SET MAXDT=$EXTRACT(NOWDT,1,5)_PRCPEND
SET Y=($EXTRACT(LASTMO,1,3)-1)_$EXTRACT(LASTMO,4,5)_"00"
DO DD^%DT
SET START=Y
+14 SET %DT="AEP"
SET %DT("A")="Compare Usage to Date (Month Year): "
SET %DT("B")=DEFAULT
SET %DT(0)=-MAXDT
WRITE !
DO ^%DT
KILL %DT
if Y<0
QUIT
SET COMDT=$EXTRACT(Y,1,5)
START SET %DT="AEP"
SET %DT("A")="Start Comparison Usage with Date (Month Year): "
SET %DT("B")=START
SET %DT(0)=-MAXDT
WRITE !
DO ^%DT
KILL %DT
if Y<0
QUIT
SET STARTDT=$EXTRACT(Y,1,5)
+1 SET %DT="AEP"
SET %DT("A")=" End Comparison Usage with Date (Month Year): "
SET %DT("B")=DEFAULT
SET %DT(0)=-MAXDT
DO ^%DT
KILL %DT
if Y<0
QUIT
SET ENDDT=$EXTRACT(Y,1,5)
+2 IF ENDDT<STARTDT
WRITE !,"END DATE MUST BE GREATER THAN OR EQUAL TO THE START DATE."
GOTO START
+3 SET DIR(0)="N^1:1000"
SET DIR("A")="Enter the percentage of change"
SET DIR("?",1)="Enter a whole number change between 1 and 1000 which represents the percentage"
SET DIR("?")="between the average (from start to end month) and the compare month."
+4 SET DIR("B")=50
WRITE !
DO ^DIR
KILL DIR
if '+Y
QUIT
SET PERCENT=+Y
+5 SET DIR(0)="S^D:Decrease in Usage;I:Increase in Usage"
SET DIR("A")="Show Items with Increase or Decrease in Usage"
SET DIR("B")="Decrease in Usage"
WRITE !
DO ^DIR
KILL DIR
+6 SET REPTYPE=$SELECT(Y="D":"DECREASE",1:"INCREASE")
SET SCREEN=$SELECT(Y="D":"I COMDATA<AVERAGE",Y="I":"I COMDATA>AVERAGE",1:"")
if SCREEN=""
QUIT
+7 ; Insert prompt for Group
+8 KILL X
SET X(1)="Select the Group Categories to display"
DO DISPLAY^PRCPUX2(2,40,.X)
+9 DO GROUPSEL^PRCPURS1(PRCP("I"))
+10 IF '$GET(GROUPALL)
IF '$ORDER(^TMP($JOB,"PRCPURS1","YES",0))
WRITE !,"*** NO GROUP CATEGORIES SELECTED !"
DO Q
QUIT
+11 WRITE !,"NOTE: The report will",$SELECT('$GET(GROUPALL):" NOT",1:"")," include items not stored in a group category."
+12 ; Insert prompt for Standard, ODI or both
+13 SET TYPNUM=$$ODIPROM^PRCPUX2(0)
+14 if TYPNUM=0
QUIT
DESC ; Insert prompt for sort order by item number or name
+1 SET SRT=$$SRTPRMP^PRCPUX2(0)
+2 if SRT=0
QUIT
+3 IF (+SRT<1)!(+SRT>2)
GOTO DESC
+4 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="Usage Demand Analysis Report"
SET ZTRTN="DQ^PRCPRUS2"
+6 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("REPTYPE")=""
SET ZTSAVE("S*")=""
SET ZTSAVE("END*")=""
SET ZTSAVE("NOW*")=""
SET ZTSAVE("COMDT")=""
SET ZTSAVE("PERCENT")=""
SET ZTSAVE("REP")=""
SET ZTSAVE("ZTREQ")="@"
SET ZTSAVE("SCREEN")=""
+7 SET ZTSAVE("GROUP*")=""
SET ZTSAVE("^TMP($J,""PRCPURS1"",")=""
SET ZTSAVE("TYP*")=""
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+8 WRITE !!,"<*> please wait <*>"
DQ ;queue comes here
+1 ;PRC*5.1*228
KILL ^TMP($JOB,"USAGE2")
SET X1=ENDDT_"00"
SET X2=STARTDT_"00"
DO ^%DTC
SET MONTHS=(X+12)\30+1
if 'MONTHS
SET MONTHS=1
+2 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if +ITEMDA=0
QUIT
Begin DoDot:1
+3 SET DATA2=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
if DATA2=""
QUIT
+4 SET GROUP=+$PIECE(DATA2,"^",21)
+5 IF 'GROUP
IF '$GET(GROUPALL)
QUIT
+6 IF $GET(GROUPALL)
IF $DATA(^TMP($JOB,"PRCPURS1","NO",GROUP))
QUIT
+7 IF '$GET(GROUPALL)
IF '$DATA(^TMP($JOB,"PRCPURS1","YES",GROUP))
QUIT
+8 SET GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
+9 IF GROUPNM'=""
SET GROUPNM=$EXTRACT(GROUPNM,1,20)_" (#"_GROUP_")"
+10 if GROUPNM=""
SET GROUPNM=" "
+11 IF SRT=2
SET ORDER=ITEMDA
+12 IF SRT=1
Begin DoDot:2
+13 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
if DESCR=""
SET DESCR=" "
+14 SET DESCR=$EXTRACT(DESCR,1,20)
+15 SET ORDER=DESCR
End DoDot:2
+16 SET DATE=STARTDT-1
SET TOTAL=0
FOR
SET DATE=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE))
if 'DATE!(DATE>ENDDT)
QUIT
SET TOTAL=TOTAL+$PIECE($GET(^(DATE,0)),"^",2)
+17 if TOTAL=""
QUIT
SET AVERAGE=TOTAL/MONTHS
SET COMDATA=+$PIECE($GET(^PRCP(445,PRCP("I"),1,ITEMDA,2,COMDT,0)),"^",2)
XECUTE SCREEN
if '$TEST
QUIT
+18 SET CHANGE=$SELECT(AVERAGE=0:"***.**",1:(COMDATA-AVERAGE)/AVERAGE*100)
if CHANGE<0
SET CHANGE=-CHANGE
IF CHANGE'["*"
IF CHANGE<PERCENT
QUIT
+19 SET ^TMP($JOB,"USAGE2",GROUPNM,ORDER,ITEMDA)=COMDATA_"^"_$JUSTIFY(AVERAGE,0,2)_"^"_$SELECT(CHANGE["*":CHANGE,1:$JUSTIFY(CHANGE,0,2))
End DoDot:1
+20 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
+21 SET Y=COMDT_"00"
DO DD^%DT
SET COMPARE=Y
SET Y=STARTDT_"00"
DO DD^%DT
SET START=Y
SET Y=ENDDT_"00"
DO DD^%DT
SET END=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+22 IF $DATA(^TMP($JOB))=0
DO END^PRCPUREP
GOTO Q
+23 SET GROUPNM=""
FOR
SET GROUPNM=$ORDER(^TMP($JOB,"USAGE2",GROUPNM))
if GROUPNM=""
QUIT
Begin DoDot:1
+24 if $DATA(PRCPFLAG)
QUIT
+25 WRITE !,?6,"GROUP: ",GROUPNM
+26 IF GROUPNM=""!(GROUPNM=" ")
WRITE "<NONE>"
+27 WRITE !
+28 IF $Y>(IOSL-5)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+29 SET ORDER=""
FOR
SET ORDER=$ORDER(^TMP($JOB,"USAGE2",GROUPNM,ORDER))
if ORDER=""
QUIT
Begin DoDot:2
+30 if $DATA(PRCPFLAG)
QUIT
+31 SET ITEMDA=""
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"USAGE2",GROUPNM,ORDER,ITEMDA))
if ITEMDA=""
QUIT
Begin DoDot:3
+32 SET ODIFLG=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+33 IF (TYPNUM=1)&(ODIFLG="Y")
QUIT
+34 IF (TYPNUM=2)&(ODIFLG'="Y")
QUIT
+35 if $DATA(PRCPFLAG)
QUIT
+36 SET DATA=$GET(^TMP($JOB,"USAGE2",GROUPNM,ORDER,ITEMDA))
+37 WRITE !,ITEMDA
+38 SET ODIFLG=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+39 IF ODIFLG="Y"
WRITE ?9,"D"
+40 WRITE ?15,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,20),?41,$JUSTIFY($PIECE(DATA,"^"),10),?55,$JUSTIFY($PIECE(DATA,"^",2),10),?70,$JUSTIFY($PIECE(DATA,"^",3),9)
+41 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+42 if $DATA(PRCPFLAG)
QUIT
+43 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
End DoDot:3
+44 if $DATA(PRCPFLAG)
QUIT
End DoDot:2
+45 if $DATA(PRCPFLAG)
QUIT
+46 WRITE !
End DoDot:1
+47 DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"USAGE2"),^TMP($JOB,"PRCPURS1")
QUIT
+1 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"USAGE DEMAND ANALYSIS FOR: ",PRCP("IN"),?(80-$LENGTH(%)),%
+2 WRITE !?5,"AVERAGE USAGE FROM ",START," TO ",END," (",MONTHS," MONTHS)"
+3 WRITE !?5,"COMPARE USAGE WITH ",COMPARE,?40,"PERCENT ",REPTYPE," AT LEAST: ",PERCENT," %"
+4 SET %=""
SET $PIECE(%,"-",81)=""
WRITE !,"IM#",?8,"OD",?15,"DESCRIPTION",?41,"COMPARE QTY",?55,"AVERAGE QTY",?70,"% "_REPTYPE,!,%
QUIT
