source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2.m@ 1804

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1PRCPLO2 ;WISC/RFJ/dh/DWA/DAP-stock status report (option, whse) ; 2/23/07 5:00pm
2 ;;5.1;IFCAP;**83,41,98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;Copied from routine ^PRCPRSSR and modified for PRC*5.1*83 (CLRS)
5 ;
6ENT ;This report will be called from option PRCPLO CLO GIP OPTION with fixed
7 ;input parameters and run for all stations and active inventory points
8 ;on a given VistA system.
9 L +^PRCP(446.7,"STATUS"):3 I $T=0 S PRCPMSG(1)="Error encountered when attempting to run CLO GIP Reports due to other",PRCPMSG(2)="CLRS extracts in progress, please try again later." D MAIL^PRCPLO3 Q
10 K ^PRCP(446.7)
11 S ^PRCP(446.7,0)="CLRS REPORT STORAGE^446.7^^"
12 N CLRSFLAG
13 S CLRSFLAG="SS" D GETIPT^PRCPLO1
14 ;*83 This call links the Stock on Hand Report in a series of two
15 ;consecutive report runs to be executed on the 1st of each month.
16 L -^PRCP(446.7,"STATUS")
17 D ENT^PRCPLO
18 N PRCPMSG S PRCPMSG(1)="CLO GIP Reports completed on "_$$HTE^XLFDT($H) D MAIL^PRCPLO3
19 Q
20 ;
21EN1 ;*83 Call coming in from PRCPLO1 with station number and inventory point
22 ;
23 N %,%DT,%H,%I,DATEINAC,DATESTRT,TODAY,X,X1,X2,Y,MNT,INARNG
24 ;*83 The following was edited to always enter the previous month as the start date
25 D NOW^%DTC S TODAY=X,Y=$E(X,1,3),MNT=$E(X,4,5)
26 S MNT=MNT-1
27 I MNT=0 S MNT=12,Y=Y-1
28 I $L(MNT)=1 S MNT=0_MNT
29 S DATESTRT=Y_MNT_"00"
30 ;
31 ;*83 The following was edited to always enter a 90 day previous to
32 ;current date default inactivity range if no other is indicated via the
33 ;PRCPLO INACTIVITY RANGE parameter
34 S INARNG=$$GET^XPAR("SYS","PRCPLO INACTIVITY RANGE",1,"Q")
35 I INARNG="" S INARNG=90
36 S X1=TODAY,X2=(INARNG*-1) D C^%DTC S DATEINAC=$E(X,1,5)_"00"
37 S DT=TODAY
38 ;
39 ;*83 Build report with station and inventory point passed in from PRCPLO1 call
40DQ ; queue starts here
41 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
42 ;*83 Added newing of variables
43 N STA,INV,TOTOPEN,TOTREC,TOTISS,TOTADJ,TOTCLOS,RECNM,TOTN,DATRN,TOTINA,TOTIS1,TOTAD1,TOTIND,TOTLNG,TOTLND,DAYS,DATRN1,ODITEM,NODE1
44 ;*98 Modified calculations to separate ODI and Standard Items
45 K ^TMP($J)
46 K OPEN
47 ;
48 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA D
49 . S NODE1=1
50 . S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
51 . I ODITEM="Y" S NODE1=2
52 . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
53 . S ^TMP($J,NODE1,"CNT",ACCT)=$G(^TMP($J,NODE1,"CNT",ACCT))+1
54 ;
55 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
56 . S NODE1=1
57 . S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
58 . I ODITEM="Y" S NODE1=2
59 . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
60 . S $P(^TMP($J,NODE1,"OPEN",ACCT),"^")=$P($G(^TMP($J,NODE1,"OPEN",ACCT)),"^")+$P(X,"^",2)+$P(X,"^",3)
61 . S $P(^TMP($J,NODE1,"OPEN",ACCT),"^",2)=$P($G(^TMP($J,NODE1,"OPEN",ACCT)),"^",2)+$P(X,"^",8)
62 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
63 . S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE,DA)) Q:'DA D
64 . . S D=$G(^PRCP(445.2,DA,0)) I '$P(D,"^",5) Q
65 . . ; non-issuable
66 . . Q:$P(D,"^",11)="N" ;count if not flagged as non-issueable
67 . . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1($P(D,"^",5)))
68 . . S TRANSNO=$P(D,"^",19)
69 . . S INVVAL=$P(D,"^",7)*$P(D,"^",8) I $P(D,"^",22)'="" S INVVAL=$P(D,"^",22)
70 . . S NODE1=1
71 . . I $$ODITEM^PRCPUX2(PRCP("I"),$P(D,"^",5))="Y" S NODE1=2
72 . . ; set transno temporary for primary and secondary to
73 . . ; indicate type of transaction
74 . . I PRCP("DPTYPE")'="W" D
75 . . . I TYPE="R"!(TYPE="C")!(TYPE="E")!(TYPE="U")!(TYPE="S") S TRANSNO="--1" Q ;issue
76 . . . I TYPE="RC" S TRANSNO=1 Q ;receipt
77 . . . S TRANSNO="" ;adjustment
78 . . ; other adjustments
79 . . I PRCP("DPTYPE")="W",$P(TRANSNO,"-",2)="" S ^TMP($J,NODE1,"ADJ",ACCT)=$G(^TMP($J,NODE1,"ADJ",ACCT))+INVVAL,^TMP($J,NODE1,"ADJN",ACCT)=$G(^TMP($J,NODE1,"ADJN",ACCT))+1 Q
80 . . I TRANSNO="" S ^TMP($J,NODE1,"ADJ",ACCT)=$G(^TMP($J,NODE1,"ADJ",ACCT))+INVVAL,^TMP($J,NODE1,"ADJN",ACCT)=$G(^TMP($J,NODE1,"ADJN",ACCT))+1
81 . . E D
82 . . . ; purchase order
83 . . . I $P(TRANSNO,"-",3)="" S ^TMP($J,NODE1,"REC",ACCT)=$G(^TMP($J,NODE1,"REC",ACCT))+INVVAL,^TMP($J,NODE1,"RECN",ACCT)=$G(^TMP($J,NODE1,"RECN",ACCT))+1 Q
84 . . . ; usage
85 . . . S ^TMP($J,NODE1,"ISS",ACCT)=$G(^TMP($J,NODE1,"ISS",ACCT))+INVVAL,^TMP($J,NODE1,"ISSN",ACCT)=$G(^TMP($J,NODE1,"ISSN",ACCT))+1
86 ; calculate inactive, long supply, set non-issuable
87 ;*98 modified long supply range to be 90 days instead of 270
88 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
89 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S D=$G(^(ITEMDA,0)) I D'="" D
90 . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
91 . ; value
92 . S NODE1=1
93 . S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
94 . I ODITEM="Y" S NODE1=2
95 . S ^TMP($J,NODE1,"VALUE",ACCT)=$G(^TMP($J,NODE1,"VALUE",ACCT))+$P(D,"^",27)
96 . S ^TMP($J,NODE1,"DUEIN",ACCT)=$G(^TMP($J,NODE1,"DUEIN",ACCT))+($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
97 . S ^TMP($J,NODE1,"DUEOUT",ACCT)=$G(^TMP($J,NODE1,"DUEOUT",ACCT))+($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
98 . ; non-issuable
99 . I $P(D,"^",19) S ^TMP($J,NODE1,"NISS",ACCT)=$G(^TMP($J,NODE1,"NISS",ACCT))+($J($P(D,"^",19)*$P(D,"^",22),0,2)),^TMP($J,NODE1,"NISSN",ACCT)=$G(^TMP($J,NODE1,"NISSN",ACCT))+1
100 . ; inactive
101 . ; if reusable, quit
102 . I $$REUSABLE^PRCPU441(ITEMDA) Q
103 . S QTY=$P(D,"^",7)+$P(D,"^",19)
104 . I QTY,'$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,$E(DATEINAC,1,5)-.01)),'$O(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATEINAC)) D
105 . . S ^TMP($J,NODE1,"INACT",ACCT)=$G(^TMP($J,NODE1,"INACT",ACCT))+$P(D,"^",27),^TMP($J,NODE1,"INACTN",ACCT)=$G(^TMP($J,NODE1,"INACTN",ACCT))+1
106 . ; long supply
107 . 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)
108 . S AVERAGE=$J(TOTAL/TOTDAYS,0,2),TOTAL=$S('AVERAGE&(QTY):9999999,'AVERAGE:0,1:QTY/AVERAGE\1)
109 . I TOTAL>90 S ^TMP($J,NODE1,"LONG",ACCT)=$G(^TMP($J,NODE1,"LONG",ACCT))+$P(D,"^",27),^TMP($J,NODE1,"LONGN",ACCT)=$G(^TMP($J,NODE1,"LONGN",ACCT))+1
110 ;
111 ;*98 Create consolidated array of Standard and On-Demand Items
112 N I,J,PRCPQ1,PRCPQ2,PRCPR1,PRCPR2,PRCPS1,PRCPS2,L,J,K,TEMPDATA
113 F I=1:1:2 D
114 . S PRCPQ1="" F S PRCPQ1=$O(^TMP($J,I,PRCPQ1)) Q:PRCPQ1="" D
115 .. S PRCPQ2="" F S PRCPQ2=$O(^TMP($J,I,PRCPQ1,PRCPQ2)) Q:PRCPQ2="" D
116 ... S TEMPDATA=^TMP($J,I,PRCPQ1,PRCPQ2)
117 ... F L=1:1:2 S $P(^TMP($J,3,PRCPQ1,PRCPQ2),"^",L)=$P($G(^TMP($J,3,PRCPQ1,PRCPQ2)),"^",L)+$P(TEMPDATA,"^",L)
118 ;
119 F J=1:1:3 D
120 . S PRCPR1="" F S PRCPR1=$O(^TMP($J,3,PRCPR1)) Q:PRCPR1="" S ^TMP($J,J,PRCPR1,"TOTAL")=0
121 ;
122 F K=1:1:3 D
123 . S PRCPS1="" F S PRCPS1=$O(^TMP($J,K,PRCPS1)) Q:PRCPS1="" D
124 .. S PRCPS2="" F S PRCPS2=$O(^TMP($J,K,PRCPS1,PRCPS2)) Q:+PRCPS2=0 D
125 ... S ^TMP($J,K,PRCPS1,"TOTAL")=$G(^TMP($J,K,PRCPS1,"TOTAL"))+$G(^TMP($J,K,PRCPS1,PRCPS2))
126 ;
127 D ENT^PRCPLO2A
128 ;
129 Q
Note: See TracBrowser for help on using the repository browser.