PRCPRUSE ;WISC/RFJ,DWA,VAC-usage demand item report ; 10/19/06 9:53am
V ;;5.1;IFCAP;**1,27,84,98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
;
N DATEEND,DATEENDD,DATESTRD,DATESTRT,DIR,GROUPALL,PRCPALLI,PRCPEND,PRCPSTRT,TOTALDAY,X,X1,X2,Y
N ODIFLG,ODITEM,REORDER,PRCPSORT
;
K X S X(1)="The Usage Demand Item Report will show the quantity of items used within a specified date period."
D DISPLAY^PRCPUX2(40,79,.X)
;
K X S X(1)="Select the date range which should be used for displaying the usage. *** Select by month & year only. ***"
D DISPLAY^PRCPUX2(2,40,.X)
D MONTHSEL^PRCPURS2
I '$G(DATEEND) Q
;
S X1=DATEEND,X2=DATESTRT D ^%DTC S TOTALDAY=X+1
S Y=DATEEND D DD^%DT
S DATEENDD=Y,Y=DATESTRT D DD^%DT
S DATESTRD=Y
W !?5,"-- TOTAL NUMBER OF DAYS: ",TOTALDAY
;
; item(s)
K X S X(1)="Select specific items to display."
D DISPLAY^PRCPUX2(2,40,.X)
D ITEMSEL^PRCPURS4
I '$G(PRCPALLI),'$O(^TMP($J,"PRCPURS4","")) Q
I '$G(PRCPALLI) D G SORT
. S GROUPALL=1
;
; whse sort
I PRCP("DPTYPE")="W" D I '$D(PRCPSTRT) Q
. K X S X(1)="Select the range of NSNs to display" D DISPLAY^PRCPUX2(2,40,.X)
. D NSNSEL^PRCPURS0
;
; prim/seco sort
I PRCP("DPTYPE")'="W" D I '$G(GROUPALL),'$O(^TMP($J,"PRCPURS1","YES",0)) W !,"*** NO GROUP CATEGORIES SELECTED !" Q
. K X S X(1)="Select the Group Categories to display" D DISPLAY^PRCPUX2(2,40,.X)
. D GROUPSEL^PRCPURS1(PRCP("I"))
;
SORT S ODIFLG=3
I PRCP("DPTYPE")'="W" D
.Q:$G(PRCPALLI)=""
.S ODIFLG=$$ODIPROM^PRCPUX2(0)
Q:ODIFLG=0
S PRCPSORT=$$SRTPRMP^PRCPUX2(0)
Q:PRCPSORT=0
;
QUEUE S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D Q
. S ZTDESC="Usage Demand Item Report",ZTRTN="DQ^PRCPRUSE"
. S ZTSAVE("^TMP($J,""PRCPURS4"",")="",ZTSAVE("^TMP($J,""PRCPURS1"",")="",ZTSAVE(ODIFLG)=""
. S ZTSAVE("DATE*")="",ZTSAVE("GROUP*")="",ZTSAVE("PRCP*")="",ZTSAVE("TOTALDAY")="",ZTSAVE("ZTREQ")="@"
. S ZTSAVE("O*")=""
. D ^%ZTLOAD
W !!,"<*> please wait <*>"
;
DQ ; queue starts here
N %,%H,%I,COLUMN,DATA,DATE,DESCR,GROUP,GROUPNM,ITEMDA,MONYR,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTCOST,TOTUSED,TTOTCOST,TTOTUSED,VALUE,X,Y
K ^TMP($J,"PRCPRUSE")
S ITEMDA=0
I $G(PRCPALLI) F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I DATA'="" D
. S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
. S VALUE=DESCR_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$P(DATA,"^",15)_"^"_$P(DATA,"^",22)_"^"_($P(DATA,"^",7)+$P(DATA,"^",19))
. ;
. ; sort for whse
. I PRCP("DPTYPE")="W" D Q
. . S NSN=$$NSN^PRCPUX1(ITEMDA) S:NSN="" NSN=" "
. . I $E(NSN,1,$L(PRCPSTRT))'=PRCPSTRT,$E(NSN,1,$L(PRCPEND))'=PRCPEND I NSN']PRCPSTRT!(PRCPEND']NSN) Q
. . I PRCPSORT=1 S ^TMP($J,"PRCPRUSE",NSN,$E(DESCR,1,15),ITEMDA)=VALUE
. . I PRCPSORT=2 S ^TMP($J,"PRCPRUSE",NSN,$E("000000000",$L(ITEMDA)+1,9)_ITEMDA,ITEMDA)=VALUE
. ;
. ; sort for primary and secondary
. S GROUP=+$P(DATA,"^",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 PRCPSORT=1 S ^TMP($J,"PRCPRUSE",GROUPNM,$E(DESCR,1,15),ITEMDA)=VALUE
. I PRCPSORT=2 S ^TMP($J,"PRCPRUSE",GROUPNM,$E("000000000",$L(ITEMDA)+1,9)_ITEMDA,ITEMDA)=VALUE
;
I '$G(PRCPALLI) F S ITEMDA=$O(^TMP($J,"PRCPURS4",ITEMDA)) Q:'ITEMDA S DATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)) I DATA'="" D
. S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
. S VALUE=DESCR_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$P(DATA,"^",15)_"^"_$P(DATA,"^",22)_"^"_($P(DATA,"^",7)+$P(DATA,"^",19))
. ;
. ; sort for whse
. I PRCP("DPTYPE")="W" D Q
. . S NSN=$$NSN^PRCPUX1(ITEMDA) S:NSN="" NSN=" "
. . I PRCPSORT=1 S ^TMP($J,"PRCPRUSE",NSN,$E(DESCR,1,15),ITEMDA)=VALUE
. . I PRCPSORT=2 S ^TMP($J,"PRCPRUSE",NSN,$E("000000000",$L(ITEMDA)+1,9)_ITEMDA,ITEMDA)=VALUE
. ;
. ; sort for primary and secondary
. S GROUP=+$P(DATA,"^",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 PRCPSORT=1 S ^TMP($J,"PRCPRUSE",GROUPNM,$E(DESCR,1,15),ITEMDA)=VALUE
. I PRCPSORT=2 S ^TMP($J,"PRCPRUSE",GROUPNM,$E("000000000",$L(ITEMDA)+1,9)_ITEMDA,ITEMDA)=VALUE
;
D PRINT^PRCPRUSP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRUSE 4705 printed Apr 09, 2024@21:11:21 Page 2
PRCPRUSE ;WISC/RFJ,DWA,VAC-usage demand item report ; 10/19/06 9:53am
V ;;5.1;IFCAP;**1,27,84,98**;Oct 20, 2000;Build 37
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+3 ;
+4 NEW DATEEND,DATEENDD,DATESTRD,DATESTRT,DIR,GROUPALL,PRCPALLI,PRCPEND,PRCPSTRT,TOTALDAY,X,X1,X2,Y
+5 NEW ODIFLG,ODITEM,REORDER,PRCPSORT
+6 ;
+7 KILL X
SET X(1)="The Usage Demand Item Report will show the quantity of items used within a specified date period."
+8 DO DISPLAY^PRCPUX2(40,79,.X)
+9 ;
+10 KILL X
SET X(1)="Select the date range which should be used for displaying the usage. *** Select by month & year only. ***"
+11 DO DISPLAY^PRCPUX2(2,40,.X)
+12 DO MONTHSEL^PRCPURS2
+13 IF '$GET(DATEEND)
QUIT
+14 ;
+15 SET X1=DATEEND
SET X2=DATESTRT
DO ^%DTC
SET TOTALDAY=X+1
+16 SET Y=DATEEND
DO DD^%DT
+17 SET DATEENDD=Y
SET Y=DATESTRT
DO DD^%DT
+18 SET DATESTRD=Y
+19 WRITE !?5,"-- TOTAL NUMBER OF DAYS: ",TOTALDAY
+20 ;
+21 ; item(s)
+22 KILL X
SET X(1)="Select specific items to display."
+23 DO DISPLAY^PRCPUX2(2,40,.X)
+24 DO ITEMSEL^PRCPURS4
+25 IF '$GET(PRCPALLI)
IF '$ORDER(^TMP($JOB,"PRCPURS4",""))
QUIT
+26 IF '$GET(PRCPALLI)
Begin DoDot:1
+27 SET GROUPALL=1
End DoDot:1
GOTO SORT
+28 ;
+29 ; whse sort
+30 IF PRCP("DPTYPE")="W"
Begin DoDot:1
+31 KILL X
SET X(1)="Select the range of NSNs to display"
DO DISPLAY^PRCPUX2(2,40,.X)
+32 DO NSNSEL^PRCPURS0
End DoDot:1
IF '$DATA(PRCPSTRT)
QUIT
+33 ;
+34 ; prim/seco sort
+35 IF PRCP("DPTYPE")'="W"
Begin DoDot:1
+36 KILL X
SET X(1)="Select the Group Categories to display"
DO DISPLAY^PRCPUX2(2,40,.X)
+37 DO GROUPSEL^PRCPURS1(PRCP("I"))
End DoDot:1
IF '$GET(GROUPALL)
IF '$ORDER(^TMP($JOB,"PRCPURS1","YES",0))
WRITE !,"*** NO GROUP CATEGORIES SELECTED !"
QUIT
+38 ;
SORT SET ODIFLG=3
+1 IF PRCP("DPTYPE")'="W"
Begin DoDot:1
+2 if $GET(PRCPALLI)=""
QUIT
+3 SET ODIFLG=$$ODIPROM^PRCPUX2(0)
End DoDot:1
+4 if ODIFLG=0
QUIT
+5 SET PRCPSORT=$$SRTPRMP^PRCPUX2(0)
+6 if PRCPSORT=0
QUIT
+7 ;
QUEUE SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+1 SET ZTDESC="Usage Demand Item Report"
SET ZTRTN="DQ^PRCPRUSE"
+2 SET ZTSAVE("^TMP($J,""PRCPURS4"",")=""
SET ZTSAVE("^TMP($J,""PRCPURS1"",")=""
SET ZTSAVE(ODIFLG)=""
+3 SET ZTSAVE("DATE*")=""
SET ZTSAVE("GROUP*")=""
SET ZTSAVE("PRCP*")=""
SET ZTSAVE("TOTALDAY")=""
SET ZTSAVE("ZTREQ")="@"
+4 SET ZTSAVE("O*")=""
+5 DO ^%ZTLOAD
End DoDot:1
QUIT
+6 WRITE !!,"<*> please wait <*>"
+7 ;
DQ ; queue starts here
+1 NEW %,%H,%I,COLUMN,DATA,DATE,DESCR,GROUP,GROUPNM,ITEMDA,MONYR,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTCOST,TOTUSED,TTOTCOST,TTOTUSED,VALUE,X,Y
+2 KILL ^TMP($JOB,"PRCPRUSE")
+3 SET ITEMDA=0
+4 IF $GET(PRCPALLI)
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
SET DATA=$GET(^(ITEMDA,0))
IF DATA'=""
Begin DoDot:1
+5 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
+6 SET VALUE=DESCR_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$PIECE(DATA,"^",15)_"^"_$PIECE(DATA,"^",22)_"^"_($PIECE(DATA,"^",7)+$PIECE(DATA,"^",19))
+7 ;
+8 ; sort for whse
+9 IF PRCP("DPTYPE")="W"
Begin DoDot:2
+10 SET NSN=$$NSN^PRCPUX1(ITEMDA)
if NSN=""
SET NSN=" "
+11 IF $EXTRACT(NSN,1,$LENGTH(PRCPSTRT))'=PRCPSTRT
IF $EXTRACT(NSN,1,$LENGTH(PRCPEND))'=PRCPEND
IF NSN']PRCPSTRT!(PRCPEND']NSN)
QUIT
+12 IF PRCPSORT=1
SET ^TMP($JOB,"PRCPRUSE",NSN,$EXTRACT(DESCR,1,15),ITEMDA)=VALUE
+13 IF PRCPSORT=2
SET ^TMP($JOB,"PRCPRUSE",NSN,$EXTRACT("000000000",$LENGTH(ITEMDA)+1,9)_ITEMDA,ITEMDA)=VALUE
End DoDot:2
QUIT
+14 ;
+15 ; sort for primary and secondary
+16 SET GROUP=+$PIECE(DATA,"^",21)
+17 IF 'GROUP
IF '$GET(GROUPALL)
QUIT
+18 IF $GET(GROUPALL)
IF $DATA(^TMP($JOB,"PRCPURS1","NO",GROUP))
QUIT
+19 IF '$GET(GROUPALL)
IF '$DATA(^TMP($JOB,"PRCPURS1","YES",GROUP))
QUIT
+20 SET GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
+21 IF GROUPNM'=""
SET GROUPNM=$EXTRACT(GROUPNM,1,20)_" (#"_GROUP_")"
+22 if GROUPNM=""
SET GROUPNM=" "
+23 IF PRCPSORT=1
SET ^TMP($JOB,"PRCPRUSE",GROUPNM,$EXTRACT(DESCR,1,15),ITEMDA)=VALUE
+24 IF PRCPSORT=2
SET ^TMP($JOB,"PRCPRUSE",GROUPNM,$EXTRACT("000000000",$LENGTH(ITEMDA)+1,9)_ITEMDA,ITEMDA)=VALUE
End DoDot:1
+25 ;
+26 IF '$GET(PRCPALLI)
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPURS4",ITEMDA))
if 'ITEMDA
QUIT
SET DATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
IF DATA'=""
Begin DoDot:1
+27 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
+28 SET VALUE=DESCR_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$PIECE(DATA,"^",15)_"^"_$PIECE(DATA,"^",22)_"^"_($PIECE(DATA,"^",7)+$PIECE(DATA,"^",19))
+29 ;
+30 ; sort for whse
+31 IF PRCP("DPTYPE")="W"
Begin DoDot:2
+32 SET NSN=$$NSN^PRCPUX1(ITEMDA)
if NSN=""
SET NSN=" "
+33 IF PRCPSORT=1
SET ^TMP($JOB,"PRCPRUSE",NSN,$EXTRACT(DESCR,1,15),ITEMDA)=VALUE
+34 IF PRCPSORT=2
SET ^TMP($JOB,"PRCPRUSE",NSN,$EXTRACT("000000000",$LENGTH(ITEMDA)+1,9)_ITEMDA,ITEMDA)=VALUE
End DoDot:2
QUIT
+35 ;
+36 ; sort for primary and secondary
+37 SET GROUP=+$PIECE(DATA,"^",21)
+38 IF 'GROUP
IF '$GET(GROUPALL)
QUIT
+39 IF $GET(GROUPALL)
IF $DATA(^TMP($JOB,"PRCPURS1","NO",GROUP))
QUIT
+40 IF '$GET(GROUPALL)
IF '$DATA(^TMP($JOB,"PRCPURS1","YES",GROUP))
QUIT
+41 SET GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
+42 IF GROUPNM'=""
SET GROUPNM=$EXTRACT(GROUPNM,1,20)_" (#"_GROUP_")"
+43 if GROUPNM=""
SET GROUPNM=" "
+44 IF PRCPSORT=1
SET ^TMP($JOB,"PRCPRUSE",GROUPNM,$EXTRACT(DESCR,1,15),ITEMDA)=VALUE
+45 IF PRCPSORT=2
SET ^TMP($JOB,"PRCPRUSE",GROUPNM,$EXTRACT("000000000",$LENGTH(ITEMDA)+1,9)_ITEMDA,ITEMDA)=VALUE
End DoDot:1
+46 ;
+47 DO PRINT^PRCPRUSP
+48 QUIT
