source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRSSR.m@ 1093

Last change on this file since 1093 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.2 KB
Line 
1PRCPRSSR ;WISC/RFJ/dh/DWA/DAP-stock status report (option, whse) ;3.13.98
2 ;;5.1;IFCAP;**17,41,98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;*83 Routine PRCPLO2 associated with PRC*5.1*83 is a modified copy of
6 ;this routine and any changes made to this routine should also be
7 ;considered for that routine as well.
8 ;
9 ;*98 Changed previous displays of "issues" to "usage"
10 ;
11 D ^PRCPUSEL Q:'$D(PRCP("I"))
12 N %,%DT,%H,%I,DATEINAC,DATESTRT,TODAY,X,X1,X2,Y
13 K X S X(1)="The Stock Status Report will print a summary of all usage, receipts, and adjustments with the opening and closing balances by account codes."
14 S X(2)="It will calculate the turnover rate, inactive item percent, long supply percent, and non-issuable percent."
15 D DISPLAY^PRCPUX2(40,79,.X)
16 K X S X(1)="Enter the date (month-year) for the Stock Status Report." D DISPLAY^PRCPUX2(2,40,.X)
17 D NOW^%DTC S TODAY=X,Y=$E(X,1,5)_"00" S %DT(0)=-Y D DD^%DT S %DT="AEP",%DT("B")=Y,%DT("A")="Print Stock Status for MONTH and YEAR: " D ^%DT K %DT I Y<1 Q
18 S DATESTRT=$E(Y,1,5)_"00"
19 K X S X(1)="The inactive item percent is calculated for items which have not had activity (receipts or usage) after a specified cutoff date." D DISPLAY^PRCPUX2(40,79,.X)
20 K X S X(1)="Enter the Inactivity cutoff date." D DISPLAY^PRCPUX2(2,40,.X)
21 S X1=TODAY,X2=-90 D C^%DTC S Y=$E(X,1,5)_"00" D DD^%DT
22 S %DT(0)=-($E(TODAY,1,5)_"00"),%DT="AEP",%DT("B")=Y,%DT("A")="Enter Inactivity Cutoff MONTH and YEAR: " D ^%DT K %DT I Y<1 Q
23 S DATEINAC=$E(Y,1,5)_"00"
24 ;
25 ;*98 Branch to PRCPRSSP if the inventory point being reported is a
26 ;primary or secondary
27 ;
28 I PRCP("DPTYPE")'="W" D ENT^PRCPRSSP Q
29 ;
30 N ZTDESC,ZTRTN,ZTSAVE,POP
31 W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
32 . S ZTDESC="Stock Status Report",ZTRTN="DQ^PRCPRSSR"
33 . S ZTSAVE("PRCP*")="",ZTSAVE("DATE*")="",ZTSAVE("ZTREQ")="@"
34 W !!,"<*> please wait <*>"
35 ;
36DQ ; queue starts here
37 N ACCT,ADJ,ADJN,AVERAGE,D,DA,DATE,DATELONG,DUEIN,DUEOUT,INACT,INACTN,INVVAL,ISS,ISSN,ITEMDA,LONG,LONGN,NONISS,NONISSN,ONHAND,OPEN,QTY,REC,RECN,TOTAL,TOTDAYS,TRANSNO,TYPE,VALUE
38 K OPEN
39 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.1,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S X=$$GETOPEN^PRCPUBAL(PRCP("I"),ITEMDA,$E(DATESTRT,1,5)) I X'="" D
40 . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
41 . S $P(OPEN(ACCT),"^")=$P($G(OPEN(ACCT)),"^")+$P(X,"^",2)+$P(X,"^",3)
42 . S $P(OPEN(ACCT),"^",2)=$P($G(OPEN(ACCT)),"^",2)+$P(X,"^",8)
43 S DATE=DATESTRT F S DATE=$O(^PRCP(445.2,"AX",PRCP("I"),DATE)) Q:$E(DATE,1,5)'=$E(DATESTRT,1,5) S TYPE="" F S TYPE=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE)) Q:TYPE="" D
44 . S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE,DA)) Q:'DA D
45 . . S D=$G(^PRCP(445.2,DA,0)) I '$P(D,"^",5) Q
46 . . ; non-issuable
47 . . Q:$P(D,"^",11)="N" ;count if not flagged as non-issueable
48 . . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1($P(D,"^",5)))
49 . . S TRANSNO=$P(D,"^",19)
50 . . S INVVAL=$P(D,"^",7)*$P(D,"^",8) I $P(D,"^",22)'="" S INVVAL=$P(D,"^",22)
51 . . ; set transno temporary for primary and secondary to
52 . . ; indicate type of transaction
53 . . I PRCP("DPTYPE")'="W" D
54 . . . I TYPE="R"!(TYPE="C")!(TYPE="E")!(TYPE="U")!(TYPE="S") S TRANSNO="--1" Q ;usage
55 . . . I TYPE="RC" S TRANSNO=1 Q ;receipt
56 . . . S TRANSNO="" ;adjustment
57 . . ; other adjustments
58 . . I PRCP("DPTYPE")="W",$P(TRANSNO,"-",2)="" S ADJ(ACCT)=$G(ADJ(ACCT))+INVVAL,ADJN(ACCT)=$G(ADJN(ACCT))+1 Q
59 . . I TRANSNO="" S ADJ(ACCT)=$G(ADJ(ACCT))+INVVAL,ADJN(ACCT)=$G(ADJN(ACCT))+1
60 . . E D
61 . . . ; purchase order
62 . . . I $P(TRANSNO,"-",3)="" S REC(ACCT)=$G(REC(ACCT))+INVVAL,RECN(ACCT)=$G(RECN(ACCT))+1 Q
63 . . . ; usage
64 . . . S ISS(ACCT)=$G(ISS(ACCT))+INVVAL,ISSN(ACCT)=$G(ISSN(ACCT))+1
65 ;
66 ; calculate inactive, long supply, set non-issuable
67 ;
68 ;*98 Modified long supply range to be 90 days instead of 270 days for
69 ;warehouse, primary, and secondary reporting
70 ;
71 S X1=$E(DT,1,5)_"01",X2=-89 D C^%DTC S DATELONG=$E(X,1,5),X1=DT,X2=$E(X,1,5)_"00" D ^%DTC S TOTDAYS=X
72 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S D=$G(^(ITEMDA,0)) I D'="" D
73 . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
74 . ; value
75 . S VALUE(ACCT)=$G(VALUE(ACCT))+$P(D,"^",27)
76 . S DUEIN(ACCT)=$G(DUEIN(ACCT))+($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
77 . S DUEOUT(ACCT)=$G(DUEOUT(ACCT))+($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
78 . ; non-issuable
79 . I $P(D,"^",19) S NONISS(ACCT)=$G(NONISS(ACCT))+($J($P(D,"^",19)*$P(D,"^",22),0,2)),NONISSN(ACCT)=$G(NONISSN(ACCT))+1
80 . ; inactive
81 . ; if reusable, quit
82 . I $$REUSABLE^PRCPU441(ITEMDA) Q
83 . S QTY=$P(D,"^",7)+$P(D,"^",19)
84 . I QTY,'$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,$E(DATEINAC,1,5)-.01)),'$O(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATEINAC)) S INACT(ACCT)=$G(INACT(ACCT))+$P(D,"^",27),INACTN(ACCT)=$G(INACTN(ACCT))+1
85 . ; long supply
86 . S DATE=DATELONG-.01,TOTAL=0 F S DATE=$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE)) Q:'DATE S TOTAL=TOTAL+$P($G(^(DATE,0)),"^",2)
87 . S AVERAGE=$J(TOTAL/TOTDAYS,0,2),TOTAL=$S('AVERAGE&(QTY):9999999,'AVERAGE:0,1:QTY/AVERAGE\1)
88 . I TOTAL>90 S LONG(ACCT)=$G(LONG(ACCT))+$P(D,"^",27),LONGN(ACCT)=$G(LONGN(ACCT))+1
89 ;
90 ;*98 Routed printing based on Warehouse
91 D PRINT^PRCPRSS0
92 Q
Note: See TracBrowser for help on using the repository browser.