source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO.m@ 736

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1PRCPLO ;WOIFO/RLL/VAC/DAP-days of stock on hand report ; 2/26/07 1:53pm
2 ;;5.1;IFCAP;**83,98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ; Note: This routine was copied from PRCPRSOH
5 ;*98 Code modification made to handle STD and ODI breakouts
6 ;
7 Q
8ENT ; Entry Point to run Program
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 CLRS extracts in progress, please try again later." D MAIL^PRCPLO3 Q
10 N TOSTDCNT,TOODICNT,TOALLCNT,TOTCNT,VALUES
11 D PRCPRINV ; Run the logic from PRCPRSOH, get params
12 D BLDFIL ; Build the output data
13 D GETVAL ; Set the ^DIE Entries in 446.7
14 L -^PRCP(446.7,"STATUS")
15 ;
16 K ^TMP($J,"PRCPSOH") ;kill off tmp data
17 K ^TMP($J,"PRCPLO") ;kill off tmp data
18 K ^TMP($J,"PRCPSOH2") ; kill off ODI tmp data
19 K ^TMP($J,"PRCPLO2") ;kill off ODI tmp data
20 Q
21 ;
22 ;
23PRCPRINV ; run INV Point
24 N CLRSFLAG
25 S CLRSFLAG="SOH"
26 D GETIPT^PRCPLO1
27 Q
28EN1 ; Added return from PRCPLO1
29 ; Q
30 N DATEEND,DATEENDD,DATESTRD,DATESTRT,DAYSLEFT,DIR,GROUPALL,PRCPDAYS,PRCPEND,PRCPSTRT,PRCPTYPE,TOTALDAY,X,X1,X2,Y,MNT,TODAY
31 N ODICNT,ODIDOL,ODIFLAG,ODIFLG,STDCNT,STDDOL
32 ;
33 ; *83 The following was edited to always enter the LAST DAY
34 ; of the previous month as the end date. End date for Oct 31, 2005
35 ; in FM 3051031, can also use 3051100 equivalent for date sort
36 ; this way, you do not have to handle months w/ 28, 29, 30 or 31 days
37 D NOW^%DTC S TODAY=X,Y=$E(X,1,3),MNT=$E(X,4,5)
38 S MNT=+(MNT)
39 S MNT=MNT-1
40 I MNT=0 S MNT=12,Y=Y-1
41 I $L(MNT)=1 S MNT=0_MNT
42 ;
43 ; *83 Added day logic to handle month/leap year, etc.
44 N DAYS,CKF
45 S DAYS=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+(MNT))
46 S DATEEND=Y_MNT_DAYS
47 I DAYS=28 D
48 . S CKF=(17+$E(DATEEND))_$E(DATEEND,2,3)
49 . S DAYS=$S(CKF#400=0:29,(CKF#4=0&(CKF#100'=0)):29,1:28)
50 . S DATEEND=Y_MNT_DAYS
51 . Q
52 ; S DATEEND=Y_MNT_"00"
53 ; *83 The following was edited to always enter a 90 day previous
54 ; to current date of report run (check param file, could change)
55 ; for the DATESTRT. Once DATEEND and DATESTRT are determined, we
56 ; can use the existing code to set the other variables
57 S X1=TODAY
58 ; *83 Report range supplied by site parameter and defaulted to 180
59 S X2=$$GET^XPAR("SYS","PRCPLO REPORT RANGE",1,"Q")
60 I X2="" S X2=180
61 S X2=(X2*-1)
62 D C^%DTC S DATESTRT=$E(X,1,5)_"01"
63 ; DATEEND and DATESTRT are set above, pass them to existing
64 ; logic below to set remaining variables
65 S X1=DATEEND,X2=DATESTRT D ^%DTC S TOTALDAY=X+1
66 S Y=DATEEND D DD^%DT S DATEENDD=Y,Y=DATESTRT D DD^%DT S DATESTRD=Y
67 ;
68 ;*83 Set PRCPTYPE=2 (always GREATER)
69 S PRCPTYPE=2
70 ;
71 ;*83 PRCPDAYS is set based on value of CLRS GREATER THAN RANGE parameter
72 ;if no value is presented in the parameter, it will default to 90
73 ;
74 S PRCPDAYS=$$GET^XPAR("SYS","PRCPLO GREATER THAN RANGE",1,"Q")
75 I PRCPDAYS="" S PRCPDAYS=90
76 ;
77 ;*83 Return PRCPSTRT="" and PRCPEND=""
78 I PRCP("DPTYPE")="W" D
79 . S PRCPSTRT="",PRCPEND=""
80 ;
81 ;*83 RETURN GROUPALL=1 to select all groups
82 I PRCP("DPTYPE")'="W" D
83 . S GROUPALL=1
84 . ; finished adding variables
85 ;
86DQ ; queue starts here
87 N AVERAGE,DATE,GROUP,GROUPNM,ITEMDA,ITEMDATA,NSN,ONHAND,TOTAL,X,Y
88 K ^TMP($J,"PRCPRSOH")
89 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S ITEMDATA=$G(^(ITEMDA,0)) I ITEMDATA'="" D
90 . S ODIFLG=1 S ODIFLAG=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
91 . I ODIFLAG="Y" S ODIFLG=2
92 . S TOTCNT(PRCP("I"),ODIFLG)=+$G(TOTCNT(PRCP("I"),ODIFLG))+1
93 . I $$REUSABLE^PRCPU441(ITEMDA) Q
94 . ; calculate total usage between dates
95 . S DATE=$E(DATESTRT,1,5)-.01,TOTAL=0 F S DATE=$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE)) Q:'DATE!(DATE>$E(DATEEND,1,5)) S TOTAL=TOTAL+$P($G(^(DATE,0)),"^",2)
96 . S AVERAGE=$J(TOTAL/TOTALDAY,0,2),ONHAND=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
97 . S DAYSLEFT=$S('AVERAGE&(ONHAND):9999999,'AVERAGE:0,1:ONHAND/AVERAGE\1)
98 . I PRCPTYPE=1,DAYSLEFT'<PRCPDAYS Q
99 . I PRCPTYPE=2,DAYSLEFT'>PRCPDAYS Q
100 . ; sort for whse
101 . I PRCP("DPTYPE")="W" D Q
102 . . S NSN=$$NSN^PRCPUX1(ITEMDA) S:NSN="" NSN=" "
103 . . I $E(NSN,1,$L(PRCPSTRT))'=PRCPSTRT,$E(NSN,1,$L(PRCPEND))'=PRCPEND I NSN']PRCPSTRT!(PRCPEND']NSN) Q
104 . . ; S ^TMP($J,"PRCPRSOH",NSN,ITEMDA)=TOTAL_"^"_AVERAGE_"^"_ONHAND_"^"_$P(DAYSLEFT,".")_"^"_$P(ITEMDATA,"^",27)
105 . . N ITMCHK
106 . . S ITMCHK=0,ITMCHK=$O(^PRCP(445,PRCP("I"),1,ITMCHK))
107 . . Q:ITMCHK=""!(+(ITMCHK)<1)
108 . . Q:+(ITMCHK)<1 ; made it to x-ref
109 . . D BLDTMP
110 . ;98* Accumulate count information
111 . S VALUES(PRCP("I"),ODIFLG)=+$G(VALUES(PRCP("I"),ODIFLG))+1
112 . ; sort for primary and secondary
113 . S GROUP=+$P(ITEMDATA,"^",21)
114 . I 'GROUP,'$G(GROUPALL) Q
115 . I $G(GROUPALL),$D(^TMP($J,"PRCPURS1","NO",GROUP)) Q
116 . I '$G(GROUPALL),'$D(^TMP($J,"PRCPURS1","YES",GROUP)) Q
117 . S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
118 . I GROUPNM'="" S GROUPNM=$E(GROUPNM,1,20)_" (#"_GROUP_")"
119 . S:GROUPNM="" GROUPNM=" "
120 . ;*83, Create TMP structure for Report
121 . N ITMCHK
122 . S ITMCHK=0,ITMCHK=$O(^PRCP(445,PRCP("I"),1,ITMCHK))
123 . Q:ITMCHK=""!(+(ITMCHK)<1)
124 . Q:ITMCHK<1 ; made it to x-ref
125 . D BLDTMP
126 . Q
127 Q
128 ;
129BLDTMP ;*83 Build ^TMP Structure for Report Server
130 ;
131 N INVTYPE,ITEMDESC,CSTCTR,INDAT,NUMLNIT,DATRN,DATRN1,INVPTID
132 N CSTC1,CSTC2,CSTC3,CSCE1,CSCE2,V4TR,V4TR1
133 ;
134 S DATRN=$$FMTE^XLFDT(+DATEEND)
135 S DATRN1=$P(DATRN," ",1)_","_$P(DATRN," ",3)
136 S ITEMDESC=$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,15) ; item Desc
137 I ITEMDESC="" S ITEMDESC="No Item Desc"
138 Q:ITEMDA=""!(+(ITEMDA)<1)
139 ;
140 S NUMLNIT=1 ; set to 1 for each line item.
141 S INVTYPE=PRCP("DPTYPE")
142 I INVTYPE="" S INVTYPE="No Inv Type"
143 S INDAT=$G(PRCP("PAR"))
144 S INVPTID=PRCP("I") ; inv point id #
145 ; Cost Center logic
146 ; Get ^PRCP(445,INVPTID,0) 7th piece (int. Cost Center #)
147 ; Get ^PRCD(420.1,IntCstCtr,0) 1st piece (external format)
148 S CSTC1=$G(^PRCP(445,INVPTID,0)),CSTC2=$P(CSTC1,"^",7),CSTC3=$P(CSTC1,"^",3)
149 S V4TR=$P(CSTC1,"^",1),V4TR1=$P(V4TR,"-",2,99) ; *83 look up name
150 S V4TR1=$TR(V4TR1,"*","|") ; $TR name to replace "*"'s with "|"'s
151 I CSTC2'="" S CSCE1=$G(^PRCD(420.1,CSTC2,0)),CSCE2=$P(CSCE1,"^",1)
152 I CSTC2="" S CSCE2="No Cost Center"
153 ; *83, Set 5th Node from ITEMDESC to ITEMDA
154 S ^TMP($J,"PRCPLO",V3,INVPTID,ITEMDA)=V3_"*"_DATRN1_"*"_INVPTID_"*"_V4TR1_"*"_NUMLNIT_"*"_$P(ITEMDATA,"^",27)_"*"_CSCE2_"*"_INVTYPE
155 ; *98 Split information for ODI and Standard
156 S ^TMP($J,"PRCPLO2",V3,INVPTID,ITEMDA,ODIFLG)=+$G(^TMP($J,"PRCPLO2",V3,INVPTID,ITEMDA,ODIFLG))+$P(ITEMDATA,"^",27)
157 Q
158BLDFIL ; Build output file
159 N IN1,IN2,IN3,IN4,IN5,OLPV,NWPV,INDDAT,TOTDOL,LNDOL,CSTCTR,LNCT,PRCPDX,INPTVAL,POINT,STID,DTTM,INVVTYP,INVPTLN
160 S IN1=0,IN2=0,IN3=0,IN4=0,IN5="INVPT",INDDAT=0,OLPV=0,NWPV=0,LNCT=0,CSTCTR=0,TOTDOL=0,LNDOL=0,INVPTLN=0
161 S STDCNT=0,ODICNT=0
162 S (STDDOL,ODIDOL)=0
163 F S IN1=$O(^TMP($J,"PRCPLO",IN1)) Q:IN1="" D
164 . ;S (STDDOL,ODIDOL)=0
165 . F S IN2=$O(^TMP($J,"PRCPLO",IN1,IN2)) Q:IN2="" D
166 . . I IN5'="INVPT" D ; init for first time through
167 . . . S INVPTLN=+$P($G(^PRCP(445,+INPTVAL,1,0)),"^",4)
168 . . . S TOSTDCNT=+$G(TOTCNT(IN2,1)),TOODICNT=+$G(TOTCNT(IN2,2)),TOALLCNT=TOSTDCNT+TOODICNT
169 . . . S PRCPDX=STID_"*"_DTTM_"*"_INPTVAL_"*"_POINT_"*"_INVVTYP_"*"_TOTDOL_"*"_IN4_"*"_INVPTLN_"*"_CSTCTR
170 . . . ; set up new ^TMP($J NODE to store totals for ^DIE set
171 . . . S ^TMP($J,"PRCPSOH",+(STID_INPTVAL))=PRCPDX
172 . . . S STDCNT=+$G(VALUES(INPTVAL,1)),ODICNT=+$G(VALUES(INPTVAL,2))
173 . . . S TOSTDCNT=+$G(TOTCNT(INPTVAL,1)),TOODICNT=+$G(TOTCNT(INPTVAL,2))
174 . . . S TOALLCNT=TOSTDCNT+TOODICNT
175 . . . S ^TMP($J,"PRCPSOH2",+(STID_INPTVAL))=STDDOL_"*"_ODIDOL_"*"_(STDDOL+ODIDOL)_"*"_STDCNT_"*"_ODICNT_"*"_(STDCNT+ODICNT)_"*"_TOSTDCNT_"*"_TOODICNT_"*"_TOALLCNT
176 . . . S IN4=0 ; reset to 0, begin counting Line items for INVPT
177 . . . S TOTDOL=0
178 . . . S LNDOL=0
179 . . . S PRCPDX=""
180 . . . S CSTCTR=""
181 . . . S (STDDOL,ODIDOL)=0
182 . . F S IN3=$O(^TMP($J,"PRCPLO",IN1,IN2,IN3)) Q:IN3="" D
183 . . . S INDDAT=$G(^TMP($J,"PRCPLO",IN1,IN2,IN3))
184 . . . S STID=$P(INDDAT,"*",1)
185 . . . S DTTM=$P(INDDAT,"*",2)
186 . . . S POINT=$P(INDDAT,"*",4)
187 . . . S INPTVAL=$P(INDDAT,"*",3) ; Inv Point ID# for DIE Set
188 . . . S CSTCTR=$P(INDDAT,"*",7)
189 . . . S LNDOL=$P(INDDAT,"*",6)
190 . . . S INVVTYP=$P(INDDAT,"*",8)
191 . . . S TOTDOL=TOTDOL+LNDOL
192 . . . S IN4=IN4+1 ; Count # of line items in Inv Pt
193 . . . S IN5=IN2 ; Invt. Point
194 . . . S STDDOL=STDDOL+$G(^TMP($J,"PRCPLO2",IN1,IN2,IN3,1))
195 . . . S ODIDOL=ODIDOL+$G(^TMP($J,"PRCPLO2",IN1,IN2,IN3,2))
196 . . . Q
197 . . Q
198 . Q
199 Q
200GETVAL ; Get values from ^TMP($J,"PRCPSOH"
201 N LP1,SOHIEN,PRCPDX
202 S LP1=0
203 F S LP1=$O(^TMP($J,"PRCPSOH",LP1)) Q:LP1="" D
204 . S PRCPDX=$G(^TMP($J,"PRCPSOH",LP1))
205 . S SOHIEN=+LP1
206 . S DR="1///"_PRCPDX
207 . D SETREC
208 . S PRCPDX=$G(^TMP($J,"PRCPSOH2",LP1))
209 . S DR="2///"_PRCPDX
210 . D SETREC
211 . Q
212 Q
213SETREC ; Set record using DIE in 446.7
214 ;
215 N PRCPDR,PRCPST,PRCPSNM,PRCPDA,PRCPDX,PRCPST,X,Y
216 S PRCPDR=DR
217 S DIC="^PRCP(446.7,",DIC(0)="L",DLAYGO=446.7,X=SOHIEN D ^DIC K DIC,DLAYGO
218 S PRCPDA=Y+0
219 S PRCPST=$P(^TMP($J,"PRCPSOH",LP1),"*",1)
220 S PRCPSNM=$$GET1^DIQ(4,PRCPST_",",.01)
221 ;*98 Send enhanced mail message if exception occurs during FileMan set
222 I Y=-1 N PRCPMSG D Q
223 . S PRCPMSG(1)="Error saving to File #446.7 for Days of Stock on Hand Report, related data: "
224 . S PRCPMSG(2)="",PRCPMSG(3)="Station: "_PRCPST_" "_PRCPSNM
225 . S PRCPMSG(4)="Inventory Point: "_$P(^TMP($J,"PRCPSOH",LP1),"*",3)_" "_$P(^TMP($J,"PRCPSOH",LP1),"*",4)
226 . S PRCPMSG(5)="File #446.7 Field Set Attempted: "_PRCPDR
227 . D MAIL^PRCPLO3 Q
228 ;
229 S DIE="^PRCP(446.7,",DA=PRCPDA D ^DIE K DIE,DR,DA
230 Q
Note: See TracBrowser for help on using the repository browser.