[613] | 1 | PRCPRIIP ;WISC/RFJ/VAC-inactive items report (primary, second) ; 10/19/06 9:14am
|
---|
| 2 | ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
|
---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
---|
| 4 | ;Modified to add a Group Category prompt and an On-Demand selection.
|
---|
| 5 | Q
|
---|
| 6 | ;
|
---|
| 7 | ;
|
---|
| 8 | PRIMARY ; inactive items report for primary and secondary
|
---|
| 9 | N DATEINAC,GROUPALL,X,Y,ODITEM,TYPNUM,ZERNUM,ODITEMFL,NEWHED,X1,X2
|
---|
| 10 | 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."
|
---|
| 11 | D DISPLAY^PRCPUX2(40,79,.X)
|
---|
| 12 | K X S X(1)="Select the Group Categories to display" D DISPLAY^PRCPUX2(2,40,.X)
|
---|
| 13 | D GROUPSEL^PRCPURS1(PRCP("I"))
|
---|
| 14 | I '$G(GROUPALL),'$O(^TMP($J,"PRCPURS1","YES",0)) W !,"*** NO GROUP CATEGORIES SELECTED !" D Q Q
|
---|
| 15 | W !,"NOTE: The report will",$S('$G(GROUPALL):" NOT",1:"")," include items not stored in a group category."
|
---|
| 16 | K X S X(1)="Enter the Inactivity cutoff date." D DISPLAY^PRCPUX2(2,40,.X)
|
---|
| 17 | S X1=DT,X2=-90 D C^%DTC S Y=$E(X,1,5)_"00" D DD^%DT
|
---|
| 18 | 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
|
---|
| 19 | S DATEINAC=$E(Y,1,5)_"00"
|
---|
| 20 | ;Insert prompts for On-Demand and Zero quantity
|
---|
| 21 | S TYPNUM=$$ODIPROM^PRCPUX2(0)
|
---|
| 22 | Q:TYPNUM=0
|
---|
| 23 | S ZERNUM=$$ZEROQTY^PRCPURS1(0)
|
---|
| 24 | Q:ZERNUM=0
|
---|
| 25 | W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
|
---|
| 26 | . S ZTDESC="Inactive Item Report",ZTRTN="DQ^PRCPRIIP"
|
---|
| 27 | . S ZTSAVE("PRCP*")="",ZTSAVE("GROUP*")="",ZTSAVE("DATEINAC")="",ZTSAVE("^TMP($J,""PRCPURS1"",")="",ZTSAVE("ZTREQ")="@",ZTSAVE("O*")="",ZTSAVE("T*")=""
|
---|
| 28 | . S ZTSAVE("Q*")="",ZTSAVE("Z*")=""
|
---|
| 29 | W !!,"<*> please wait <*>"
|
---|
| 30 | DQ ; queue starts here
|
---|
| 31 | N %,%I,D,DATEFROM,DESCR,DUEOUT,GROUP,GROUPNM,ITEMDA,NOW,PAGE,PRCPFLAG,QTY,RECPT,SCREEN,TOTAL,TOTDAYS,USAGE,X,Y
|
---|
| 32 | K ^TMP($J,"PRCPRIIP")
|
---|
| 33 | S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S D=$G(^(ITEMDA,0)) I D'="" D
|
---|
| 34 | . ; if reusable quit
|
---|
| 35 | . I $$REUSABLE^PRCPU441(ITEMDA) Q
|
---|
| 36 | . ;Check if ODI, STD or Both
|
---|
| 37 | . S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
|
---|
| 38 | . I (ODITEM="Y")&(TYPNUM=1) Q
|
---|
| 39 | . I (ODITEM'="Y")&(TYPNUM=2) Q
|
---|
| 40 | . S QTY=$P(D,"^",7)+$P(D,"^",19)
|
---|
| 41 | . ;Check if Zero qty is to be printed
|
---|
| 42 | . I (+QTY=0)&(ZERNUM=2) Q
|
---|
| 43 | . I (+QTY'=0)&(ZERNUM=3) Q
|
---|
| 44 | . S GROUP=+$P(D,"^",21)
|
---|
| 45 | . I 'GROUP,'$G(GROUPALL) Q
|
---|
| 46 | . I $G(GROUPALL),$D(^TMP($J,"PRCPURS1","NO",GROUP)) Q
|
---|
| 47 | . I '$G(GROUPALL),'$D(^TMP($J,"PRCPURS1","YES",GROUP)) Q
|
---|
| 48 | . S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
|
---|
| 49 | . I GROUPNM'="" S GROUPNM=$E(GROUPNM,1,20)_" (#"_GROUP_")"
|
---|
| 50 | . S:GROUPNM="" GROUPNM=" "
|
---|
| 51 | . S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
|
---|
| 52 | . I $O(^PRCP(445,PRCP("I"),1,ITEMDA,2,$E(DATEINAC,1,5)-.01))!($O(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATEINAC))) Q
|
---|
| 53 | . ; find last usage date
|
---|
| 54 | . S (USAGE,X)=0 F S X=$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,X)) Q:'X S USAGE=X
|
---|
| 55 | . S USAGE=$S('USAGE:"",1:$E(USAGE,4,5)_"/"_$E(USAGE,2,3))
|
---|
| 56 | . ; find last receipt date
|
---|
| 57 | . S (RECPT,X)=0 F S X=$O(^PRCP(445,PRCP("I"),1,ITEMDA,3,X)) Q:'X S RECPT=X
|
---|
| 58 | . S RECPT=$S('RECPT:"",1:$E(RECPT,4,5)_"/"_$E(RECPT,6,7)_"/"_$E(RECPT,2,3))
|
---|
| 59 | . S DUEOUT=$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA) I 'DUEOUT S DUEOUT=""
|
---|
| 60 | . S ^TMP($J,"PRCPRIIP",GROUPNM,$E(DESCR,1,15),ITEMDA)=USAGE_"^"_RECPT_"^"_DUEOUT_"^"_QTY_"^"_$P(D,"^",27)_"^"_$S($P(D,"^",26)="Y":"*",1:"")_"^"_ODITEM
|
---|
| 61 | ; print report
|
---|
| 62 | S X1=DT,X2=DATEINAC D ^%DTC S TOTDAYS=X
|
---|
| 63 | S Y=DATEINAC D DD^%DT S DATEFROM=Y
|
---|
| 64 | D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
|
---|
| 65 | S TOTAL=0,GROUP="" F S GROUP=$O(^TMP($J,"PRCPRIIP",GROUP)) Q:GROUP=""!($G(PRCPFLAG)) D
|
---|
| 66 | . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
|
---|
| 67 | . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
|
---|
| 68 | . W !!?5,"GROUP: ",$S(GROUP=" ":"<<NONE>>",1:GROUP)
|
---|
| 69 | . 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
|
---|
| 70 | . . S ODITEMFL=$P($G(^TMP($J,"PRCPRIIP",GROUP,DESCR,ITEMDA)),"^",7)
|
---|
| 71 | . . W !,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,32),?33,ITEMDA
|
---|
| 72 | . . I ODITEMFL="Y" W ?41,"D"
|
---|
| 73 | . . 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)
|
---|
| 74 | . . S TOTAL=TOTAL+$P(D,"^",5)
|
---|
| 75 | . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
|
---|
| 76 | I '$G(PRCPFLAG),$Y>(IOSL-3) D:SCREEN P^PRCPUREP I '$G(PRCPFLAG) D H
|
---|
| 77 | I $G(PRCPFLAG) D Q Q
|
---|
| 78 | W !!?30,"TOTAL INACTIVE ITEM VALUE IN STOCK: ",$J(TOTAL,12,2)
|
---|
| 79 | D END^PRCPUREP
|
---|
| 80 | Q D ^%ZISC K ^TMP($J,"PRCPRIIP"),^TMP($J,"PRCPURS1")
|
---|
| 81 | Q
|
---|
| 82 | ;
|
---|
| 83 | ;
|
---|
| 84 | H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
|
---|
| 85 | W $C(13),"INACTIVE ITEM REPORT FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
|
---|
| 86 | S %="",$P(%,"-",81)=""
|
---|
| 87 | W !?5,"INACTIVE ITEMS RANGE FROM ",DATEFROM," TO ",$P(NOW,"@")," (",TOTDAYS," DAYS)"
|
---|
| 88 | I TYPNUM=1 S NEWHED="EXCLUDES ON-DEMAND ITEMS "
|
---|
| 89 | I TYPNUM=2 S NEWHED="ON-DEMAND ITEMS ONLY "
|
---|
| 90 | I TYPNUM=3 S NEWHED="STANDARD AND ON-DEMAND ITEMS "
|
---|
| 91 | I ZERNUM=1 S NEWHED=NEWHED_" INCLUDES ZERO QUANTITY ITEMS"
|
---|
| 92 | I ZERNUM=2 S NEWHED=NEWHED_" EXCLUDES ZERO QUANTITY ITEMS"
|
---|
| 93 | I ZERNUM=3 S NEWHED=NEWHED_" INCLUDES ONLY ZERO QUANTITY ITEMS"
|
---|
| 94 | W !?5,NEWHED,?79,"K"
|
---|
| 95 | W !?41,"O"
|
---|
| 96 | 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",!,%
|
---|
| 97 | Q
|
---|