PRCPRIIP ;WISC/RFJ/VAC-inactive items report (primary, second) ; 10/19/06 9:14am
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
;Modified to add a Group Category prompt and an On-Demand selection.
Q
;
;
PRIMARY ; inactive items report for primary and secondary
N DATEINAC,GROUPALL,X,Y,ODITEM,TYPNUM,ZERNUM,ODITEMFL,NEWHED,X1,X2
K X S X(1)="The Inactive Items Report will print items which have no receipts or issues after a specified cutoff date. The report is sorted by group category and description."
D DISPLAY^PRCPUX2(40,79,.X)
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."
K X S X(1)="Enter the Inactivity cutoff date." D DISPLAY^PRCPUX2(2,40,.X)
S X1=DT,X2=-90 D C^%DTC S Y=$E(X,1,5)_"00" D DD^%DT
S %DT(0)=-($E(DT,1,5)_"00"),%DT="AEP",%DT("B")=Y,%DT("A")="Enter Inactivity Cutoff MONTH and YEAR: " D ^%DT K %DT I Y<1 Q
S DATEINAC=$E(Y,1,5)_"00"
;Insert prompts for On-Demand and Zero quantity
S TYPNUM=$$ODIPROM^PRCPUX2(0)
Q:TYPNUM=0
S ZERNUM=$$ZEROQTY^PRCPURS1(0)
Q:ZERNUM=0
W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
. S ZTDESC="Inactive Item Report",ZTRTN="DQ^PRCPRIIP"
. S ZTSAVE("PRCP*")="",ZTSAVE("GROUP*")="",ZTSAVE("DATEINAC")="",ZTSAVE("^TMP($J,""PRCPURS1"",")="",ZTSAVE("ZTREQ")="@",ZTSAVE("O*")="",ZTSAVE("T*")=""
. S ZTSAVE("Q*")="",ZTSAVE("Z*")=""
W !!,"<*> please wait <*>"
DQ ; queue starts here
N %,%I,D,DATEFROM,DESCR,DUEOUT,GROUP,GROUPNM,ITEMDA,NOW,PAGE,PRCPFLAG,QTY,RECPT,SCREEN,TOTAL,TOTDAYS,USAGE,X,Y
K ^TMP($J,"PRCPRIIP")
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S D=$G(^(ITEMDA,0)) I D'="" D
. ; if reusable quit
. I $$REUSABLE^PRCPU441(ITEMDA) Q
. ;Check if ODI, STD or Both
. S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
. I (ODITEM="Y")&(TYPNUM=1) Q
. I (ODITEM'="Y")&(TYPNUM=2) Q
. S QTY=$P(D,"^",7)+$P(D,"^",19)
. ;Check if Zero qty is to be printed
. I (+QTY=0)&(ZERNUM=2) Q
. I (+QTY'=0)&(ZERNUM=3) Q
. S GROUP=+$P(D,"^",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=" "
. S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
. I $O(^PRCP(445,PRCP("I"),1,ITEMDA,2,$E(DATEINAC,1,5)-.01))!($O(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATEINAC))) Q
. ; find last usage date
. S (USAGE,X)=0 F S X=$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,X)) Q:'X S USAGE=X
. S USAGE=$S('USAGE:"",1:$E(USAGE,4,5)_"/"_$E(USAGE,2,3))
. ; find last receipt date
. S (RECPT,X)=0 F S X=$O(^PRCP(445,PRCP("I"),1,ITEMDA,3,X)) Q:'X S RECPT=X
. S RECPT=$S('RECPT:"",1:$E(RECPT,4,5)_"/"_$E(RECPT,6,7)_"/"_$E(RECPT,2,3))
. S DUEOUT=$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA) I 'DUEOUT S DUEOUT=""
. S ^TMP($J,"PRCPRIIP",GROUPNM,$E(DESCR,1,15),ITEMDA)=USAGE_"^"_RECPT_"^"_DUEOUT_"^"_QTY_"^"_$P(D,"^",27)_"^"_$S($P(D,"^",26)="Y":"*",1:"")_"^"_ODITEM
; print report
S X1=DT,X2=DATEINAC D ^%DTC S TOTDAYS=X
S Y=DATEINAC D DD^%DT S DATEFROM=Y
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
S TOTAL=0,GROUP="" F S GROUP=$O(^TMP($J,"PRCPRIIP",GROUP)) Q:GROUP=""!($G(PRCPFLAG)) D
. I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
. I $Y>(IOSL-6) 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,"PRCPRIIP",GROUP,DESCR)) Q:DESCR=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRIIP",GROUP,DESCR,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) S D=^(ITEMDA) D
. . S ODITEMFL=$P($G(^TMP($J,"PRCPRIIP",GROUP,DESCR,ITEMDA)),"^",7)
. . W !,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,32),?33,ITEMDA
. . I ODITEMFL="Y" W ?41,"D"
. . W ?43,$J($P(D,"^"),5),$J($P(D,"^",2),10),$J($P(D,"^",3),5),$J($P(D,"^",4),7),$J($P(D,"^",5),8,2),$J($P(D,"^",6),2)
. . S TOTAL=TOTAL+$P(D,"^",5)
. . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
I '$G(PRCPFLAG),$Y>(IOSL-3) D:SCREEN P^PRCPUREP I '$G(PRCPFLAG) D H
I $G(PRCPFLAG) D Q Q
W !!?30,"TOTAL INACTIVE ITEM VALUE IN STOCK: ",$J(TOTAL,12,2)
D END^PRCPUREP
Q D ^%ZISC K ^TMP($J,"PRCPRIIP"),^TMP($J,"PRCPURS1")
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"INACTIVE ITEM REPORT FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
S %="",$P(%,"-",81)=""
W !?5,"INACTIVE ITEMS RANGE FROM ",DATEFROM," TO ",$P(NOW,"@")," (",TOTDAYS," DAYS)"
I TYPNUM=1 S NEWHED="EXCLUDES ON-DEMAND ITEMS "
I TYPNUM=2 S NEWHED="ON-DEMAND ITEMS ONLY "
I TYPNUM=3 S NEWHED="STANDARD AND ON-DEMAND ITEMS "
I ZERNUM=1 S NEWHED=NEWHED_" INCLUDES ZERO QUANTITY ITEMS"
I ZERNUM=2 S NEWHED=NEWHED_" EXCLUDES ZERO QUANTITY ITEMS"
I ZERNUM=3 S NEWHED=NEWHED_" INCLUDES ONLY ZERO QUANTITY ITEMS"
W !?5,NEWHED,?79,"K"
W !?41,"O"
W ?44,"LAST",?53,"LAST",?60,"DUE",?67,"QTY",?73,"TOTAL",?79,"W",!,"DESCRIPTION",?36,"IM",?41,"D",?43,"USAGE",?50,"RECEIPT",?60,"OUT",?65,"ONHND",?73,"VALUE",?79,"Z",!,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRIIP 5563 printed Sep 23, 2025@19:51:01 Page 2
PRCPRIIP ;WISC/RFJ/VAC-inactive items report (primary, second) ; 10/19/06 9:14am
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Modified to add a Group Category prompt and an On-Demand selection.
+4 QUIT
+5 ;
+6 ;
PRIMARY ; inactive items report for primary and secondary
+1 NEW DATEINAC,GROUPALL,X,Y,ODITEM,TYPNUM,ZERNUM,ODITEMFL,NEWHED,X1,X2
+2 KILL X
SET X(1)="The Inactive Items Report will print items which have no receipts or issues after a specified cutoff date. The report is sorted by group category and description."
+3 DO DISPLAY^PRCPUX2(40,79,.X)
+4 KILL X
SET X(1)="Select the Group Categories to display"
DO DISPLAY^PRCPUX2(2,40,.X)
+5 DO GROUPSEL^PRCPURS1(PRCP("I"))
+6 IF '$GET(GROUPALL)
IF '$ORDER(^TMP($JOB,"PRCPURS1","YES",0))
WRITE !,"*** NO GROUP CATEGORIES SELECTED !"
DO Q
QUIT
+7 WRITE !,"NOTE: The report will",$SELECT('$GET(GROUPALL):" NOT",1:"")," include items not stored in a group category."
+8 KILL X
SET X(1)="Enter the Inactivity cutoff date."
DO DISPLAY^PRCPUX2(2,40,.X)
+9 SET X1=DT
SET X2=-90
DO C^%DTC
SET Y=$EXTRACT(X,1,5)_"00"
DO DD^%DT
+10 SET %DT(0)=-($EXTRACT(DT,1,5)_"00")
SET %DT="AEP"
SET %DT("B")=Y
SET %DT("A")="Enter Inactivity Cutoff MONTH and YEAR: "
DO ^%DT
KILL %DT
IF Y<1
QUIT
+11 SET DATEINAC=$EXTRACT(Y,1,5)_"00"
+12 ;Insert prompts for On-Demand and Zero quantity
+13 SET TYPNUM=$$ODIPROM^PRCPUX2(0)
+14 if TYPNUM=0
QUIT
+15 SET ZERNUM=$$ZEROQTY^PRCPURS1(0)
+16 if ZERNUM=0
QUIT
+17 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+18 SET ZTDESC="Inactive Item Report"
SET ZTRTN="DQ^PRCPRIIP"
+19 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("GROUP*")=""
SET ZTSAVE("DATEINAC")=""
SET ZTSAVE("^TMP($J,""PRCPURS1"",")=""
SET ZTSAVE("ZTREQ")="@"
SET ZTSAVE("O*")=""
SET ZTSAVE("T*")=""
+20 SET ZTSAVE("Q*")=""
SET ZTSAVE("Z*")=""
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+21 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW %,%I,D,DATEFROM,DESCR,DUEOUT,GROUP,GROUPNM,ITEMDA,NOW,PAGE,PRCPFLAG,QTY,RECPT,SCREEN,TOTAL,TOTDAYS,USAGE,X,Y
+2 KILL ^TMP($JOB,"PRCPRIIP")
+3 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
SET D=$GET(^(ITEMDA,0))
IF D'=""
Begin DoDot:1
+4 ; if reusable quit
+5 IF $$REUSABLE^PRCPU441(ITEMDA)
QUIT
+6 ;Check if ODI, STD or Both
+7 SET ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+8 IF (ODITEM="Y")&(TYPNUM=1)
QUIT
+9 IF (ODITEM'="Y")&(TYPNUM=2)
QUIT
+10 SET QTY=$PIECE(D,"^",7)+$PIECE(D,"^",19)
+11 ;Check if Zero qty is to be printed
+12 IF (+QTY=0)&(ZERNUM=2)
QUIT
+13 IF (+QTY'=0)&(ZERNUM=3)
QUIT
+14 SET GROUP=+$PIECE(D,"^",21)
+15 IF 'GROUP
IF '$GET(GROUPALL)
QUIT
+16 IF $GET(GROUPALL)
IF $DATA(^TMP($JOB,"PRCPURS1","NO",GROUP))
QUIT
+17 IF '$GET(GROUPALL)
IF '$DATA(^TMP($JOB,"PRCPURS1","YES",GROUP))
QUIT
+18 SET GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
+19 IF GROUPNM'=""
SET GROUPNM=$EXTRACT(GROUPNM,1,20)_" (#"_GROUP_")"
+20 if GROUPNM=""
SET GROUPNM=" "
+21 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
if DESCR=""
SET DESCR=" "
+22 IF $ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,$EXTRACT(DATEINAC,1,5)-.01))!($ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATEINAC)))
QUIT
+23 ; find last usage date
+24 SET (USAGE,X)=0
FOR
SET X=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,X))
if 'X
QUIT
SET USAGE=X
+25 SET USAGE=$SELECT('USAGE:"",1:$EXTRACT(USAGE,4,5)_"/"_$EXTRACT(USAGE,2,3))
+26 ; find last receipt date
+27 SET (RECPT,X)=0
FOR
SET X=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,3,X))
if 'X
QUIT
SET RECPT=X
+28 SET RECPT=$SELECT('RECPT:"",1:$EXTRACT(RECPT,4,5)_"/"_$EXTRACT(RECPT,6,7)_"/"_$EXTRACT(RECPT,2,3))
+29 SET DUEOUT=$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)
IF 'DUEOUT
SET DUEOUT=""
+30 SET ^TMP($JOB,"PRCPRIIP",GROUPNM,$EXTRACT(DESCR,1,15),ITEMDA)=USAGE_"^"_RECPT_"^"_DUEOUT_"^"_QTY_"^"_$PIECE(D,"^",27)_"^"_$SELECT($PIECE(D,"^",26)="Y":"*",1:"")_"^"_ODITEM
End DoDot:1
+31 ; print report
+32 SET X1=DT
SET X2=DATEINAC
DO ^%DTC
SET TOTDAYS=X
+33 SET Y=DATEINAC
DO DD^%DT
SET DATEFROM=Y
+34 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+35 SET TOTAL=0
SET GROUP=""
FOR
SET GROUP=$ORDER(^TMP($JOB,"PRCPRIIP",GROUP))
if GROUP=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+36 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
+37 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+38 WRITE !!?5,"GROUP: ",$SELECT(GROUP=" ":"<<NONE>>",1:GROUP)
+39 SET DESCR=""
FOR
SET DESCR=$ORDER(^TMP($JOB,"PRCPRIIP",GROUP,DESCR))
if DESCR=""!($GET(PRCPFLAG))
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRIIP",GROUP,DESCR,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
SET D=^(ITEMDA)
Begin DoDot:2
+40 SET ODITEMFL=$PIECE($GET(^TMP($JOB,"PRCPRIIP",GROUP,DESCR,ITEMDA)),"^",7)
+41 WRITE !,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,32),?33,ITEMDA
+42 IF ODITEMFL="Y"
WRITE ?41,"D"
+43 WRITE ?43,$JUSTIFY($PIECE(D,"^"),5),$JUSTIFY($PIECE(D,"^",2),10),$JUSTIFY($PIECE(D,"^",3),5),$JUSTIFY($PIECE(D,"^",4),7),$JUSTIFY($PIECE(D,"^",5),8,2),$JUSTIFY($PIECE(D,"^",6),2)
+44 SET TOTAL=TOTAL+$PIECE(D,"^",5)
+45 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:2
End DoDot:1
+46 IF '$GET(PRCPFLAG)
IF $Y>(IOSL-3)
if SCREEN
DO P^PRCPUREP
IF '$GET(PRCPFLAG)
DO H
+47 IF $GET(PRCPFLAG)
DO Q
QUIT
+48 WRITE !!?30,"TOTAL INACTIVE ITEM VALUE IN STOCK: ",$JUSTIFY(TOTAL,12,2)
+49 DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPRIIP"),^TMP($JOB,"PRCPURS1")
+1 QUIT
+2 ;
+3 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"INACTIVE ITEM REPORT FOR: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
+2 SET %=""
SET $PIECE(%,"-",81)=""
+3 WRITE !?5,"INACTIVE ITEMS RANGE FROM ",DATEFROM," TO ",$PIECE(NOW,"@")," (",TOTDAYS," DAYS)"
+4 IF TYPNUM=1
SET NEWHED="EXCLUDES ON-DEMAND ITEMS "
+5 IF TYPNUM=2
SET NEWHED="ON-DEMAND ITEMS ONLY "
+6 IF TYPNUM=3
SET NEWHED="STANDARD AND ON-DEMAND ITEMS "
+7 IF ZERNUM=1
SET NEWHED=NEWHED_" INCLUDES ZERO QUANTITY ITEMS"
+8 IF ZERNUM=2
SET NEWHED=NEWHED_" EXCLUDES ZERO QUANTITY ITEMS"
+9 IF ZERNUM=3
SET NEWHED=NEWHED_" INCLUDES ONLY ZERO QUANTITY ITEMS"
+10 WRITE !?5,NEWHED,?79,"K"
+11 WRITE !?41,"O"
+12 WRITE ?44,"LAST",?53,"LAST",?60,"DUE",?67,"QTY",?73,"TOTAL",?79,"W",!,"DESCRIPTION",?36,"IM",?41,"D",?43,"USAGE",?50,"RECEIPT",?60,"OUT",?65,"ONHND",?73,"VALUE",?79,"Z",!,%
+13 QUIT
