PRCPRIIR ;WISC/RFJ-inactive item report (option, whse) ;10 Aug 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$D(PRCP("I"))
I PRCP("DPTYPE")'="W" D PRIMARY^PRCPRIIP Q
;
N DATEINAC,PRCPEND,PRCPSTRT,X,Y
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 NSN."
D DISPLAY^PRCPUX2(40,79,.X)
K X S X(1)="Select the range of NSNs to display" D DISPLAY^PRCPUX2(2,40,.X)
D NSNSEL^PRCPURS0 I '$D(PRCPSTRT) Q
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"
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^PRCPRIIR"
. S ZTSAVE("PRCP*")="",ZTSAVE("DATEINAC")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ; queue starts here
N %,%I,D,DATEFROM,DUEOUT,ITEMDA,NOW,NSN,PAGE,PRCPFLAG,QTY,RECPT,SCREEN,TOTAL,TOTDAYS,USAGE,X,Y
K ^TMP($J,"PRCPRIIR")
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
. S QTY=$P(D,"^",7)+$P(D,"^",19) I 'QTY 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 $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,"PRCPRIIR",NSN,ITEMDA)=USAGE_"^"_RECPT_"^"_DUEOUT_"^"_QTY_"^"_$P(D,"^",27)_"^"_$S($P(D,"^",26)="Y":"*",1:"")
; 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,NSN="" F S NSN=$O(^TMP($J,"PRCPRIIR",NSN)) Q:NSN=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRIIR",NSN,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) S D=^(ITEMDA) D
. I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
. W !,$TR(NSN,"-"),?15,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,20),?36,ITEMDA
. W ?42,$J($P(D,"^"),5),$J($P(D,"^",2),10),$J($P(D,"^",3),6),$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,"PRCPRIIR")
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)",?79,"K"
W !?42,$J("LAST",5),$J("LAST",10),$J("DUE",6),$J("QTY",7),$J("TOTAL",8),$J("W",2),!,"NSN",?15,"DESCRIPTION",?36,"MI",?42,$J("USAGE",5),$J("RECEIPT",10),$J("OUT",6),$J("ONHND",7),$J("VALUE",8),$J("Z",2),!,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRIIR 3738 printed Dec 13, 2024@02:14:58 Page 2
PRCPRIIR ;WISC/RFJ-inactive item report (option, whse) ;10 Aug 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$DATA(PRCP("I"))
QUIT
+4 IF PRCP("DPTYPE")'="W"
DO PRIMARY^PRCPRIIP
QUIT
+5 ;
+6 NEW DATEINAC,PRCPEND,PRCPSTRT,X,Y
+7 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 NSN."
+8 DO DISPLAY^PRCPUX2(40,79,.X)
+9 KILL X
SET X(1)="Select the range of NSNs to display"
DO DISPLAY^PRCPUX2(2,40,.X)
+10 DO NSNSEL^PRCPURS0
IF '$DATA(PRCPSTRT)
QUIT
+11 KILL X
SET X(1)="Enter the Inactivity cutoff date."
DO DISPLAY^PRCPUX2(2,40,.X)
+12 SET X1=DT
SET X2=-90
DO C^%DTC
SET Y=$EXTRACT(X,1,5)_"00"
DO DD^%DT
+13 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
+14 SET DATEINAC=$EXTRACT(Y,1,5)_"00"
+15 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+16 SET ZTDESC="Inactive Item Report"
SET ZTRTN="DQ^PRCPRIIR"
+17 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("DATEINAC")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+18 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW %,%I,D,DATEFROM,DUEOUT,ITEMDA,NOW,NSN,PAGE,PRCPFLAG,QTY,RECPT,SCREEN,TOTAL,TOTDAYS,USAGE,X,Y
+2 KILL ^TMP($JOB,"PRCPRIIR")
+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 SET QTY=$PIECE(D,"^",7)+$PIECE(D,"^",19)
IF 'QTY
QUIT
+7 SET NSN=$$NSN^PRCPUX1(ITEMDA)
if NSN=""
SET NSN=" "
+8 IF $EXTRACT(NSN,1,$LENGTH(PRCPSTRT))'=PRCPSTRT
IF $EXTRACT(NSN,1,$LENGTH(PRCPEND))'=PRCPEND
IF NSN']PRCPSTRT!(PRCPEND']NSN)
QUIT
+9 IF $ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,$EXTRACT(DATEINAC,1,5)-.01))!($ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATEINAC)))
QUIT
+10 ; find last usage date
+11 SET (USAGE,X)=0
FOR
SET X=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,X))
if 'X
QUIT
SET USAGE=X
+12 SET USAGE=$SELECT('USAGE:"",1:$EXTRACT(USAGE,4,5)_"/"_$EXTRACT(USAGE,2,3))
+13 ; find last receipt date
+14 SET (RECPT,X)=0
FOR
SET X=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,3,X))
if 'X
QUIT
SET RECPT=X
+15 SET RECPT=$SELECT('RECPT:"",1:$EXTRACT(RECPT,4,5)_"/"_$EXTRACT(RECPT,6,7)_"/"_$EXTRACT(RECPT,2,3))
+16 SET DUEOUT=$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)
IF 'DUEOUT
SET DUEOUT=""
+17 SET ^TMP($JOB,"PRCPRIIR",NSN,ITEMDA)=USAGE_"^"_RECPT_"^"_DUEOUT_"^"_QTY_"^"_$PIECE(D,"^",27)_"^"_$SELECT($PIECE(D,"^",26)="Y":"*",1:"")
End DoDot:1
+18 ; print report
+19 SET X1=DT
SET X2=DATEINAC
DO ^%DTC
SET TOTDAYS=X
+20 SET Y=DATEINAC
DO DD^%DT
SET DATEFROM=Y
+21 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+22 SET TOTAL=0
SET NSN=""
FOR
SET NSN=$ORDER(^TMP($JOB,"PRCPRIIR",NSN))
if NSN=""!($GET(PRCPFLAG))
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRIIR",NSN,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
SET D=^(ITEMDA)
Begin DoDot:1
+23 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
+24 WRITE !,$TRANSLATE(NSN,"-"),?15,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,20),?36,ITEMDA
+25 WRITE ?42,$JUSTIFY($PIECE(D,"^"),5),$JUSTIFY($PIECE(D,"^",2),10),$JUSTIFY($PIECE(D,"^",3),6),$JUSTIFY($PIECE(D,"^",4),7),$JUSTIFY($PIECE(D,"^",5),8,2),$JUSTIFY($PIECE(D,"^",6),2)
+26 SET TOTAL=TOTAL+$PIECE(D,"^",5)
+27 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:1
+28 IF '$GET(PRCPFLAG)
IF $Y>(IOSL-3)
if SCREEN
DO P^PRCPUREP
IF '$GET(PRCPFLAG)
DO H
+29 IF $GET(PRCPFLAG)
DO Q
QUIT
+30 WRITE !!?30,"TOTAL INACTIVE ITEM VALUE IN STOCK: ",$JUSTIFY(TOTAL,12,2)
+31 DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPRIIR")
+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)",?79,"K"
+4 WRITE !?42,$JUSTIFY("LAST",5),$JUSTIFY("LAST",10),$JUSTIFY("DUE",6),$JUSTIFY("QTY",7),$JUSTIFY("TOTAL",8),$JUSTIFY("W",2),!,"NSN",?15,"DESCRIPTION",?36,"MI",?42,$JUSTIFY("USAGE",5),$JUSTIFY("RECEIPT",10),...
... $JUSTIFY("OUT",6),$JUSTIFY("ONHND",7),$JUSTIFY("VALUE",8),$JUSTIFY("Z",2),!,%
+5 QUIT
