source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOP8.m@ 1639

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1PSUOP8 ;BIR/DAM - Outpatient AMIS Summary Message;04 MAR 2004
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4 ;Reference to file #59 supported by DBIA 2510
5 ;
6EN ;Entry point for MailMan message
7 ;Called from PSUOP0
8 ;
9 Q:$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG")) ;Quit if Provider extract only
10 D MSG
11 D MAIL
12 Q
13 ;
14MSG ;Create the Rx AMIS summary mailman message
15 ;Called from PSUOP0
16 ;
17 S (PSU30,PSU60,PSU90,PSUNADJ,PSUEQ,PSUTCST,PSUNADC,PSUCFIL)=""
18 S (PSUNEW,PSUREF,PSUWN,PSUWNCS,PSUML,PSUMLCS,PSUMP,PSULC)=""
19 S (PSUSTF,PSUFEE,PSULOCS,PSUSTNM)=""
20 ;
21 S PSUST=$P($G(^XTMP("PSU_"_PSUJOB,"PSUSITE")),U,1) ;Facility #
22 S PSUSTNM=$P($G(^XTMP("PSU_"_PSUJOB,"PSUSITE")),U,2) ;Facility name
23 ;
24 D TCOST ;Calculate total cost for all Rx fills
25 ;
26 S Y=PSUSDT X ^DD("DD") S PSUDTS=Y
27 S Y=PSUEDT X ^DD("DD") S PSUDTE=Y
28 S AMIS(1)="Outpatient AMIS Summary for "_PSUDTS_" through "_PSUDTE_" for "_PSUSTNM
29 ;
30 S AMIS(2)=""
31 ;
32 S AMIS(3)=" Unadj 30Day Cost/ Cost/"
33 ;
34 S AMIS(4)=" 30Day 60Day 90Day Total Equiv Total Unadj 30Day"
35 ;
36 S AMIS(5)="Division Fills Fills Fills Fills Fills Cost Fill Fill"
37 ;
38 S $P(AMIS(6),"-",132)="" ;Separator bar
39 ;
40 S PSULN=7
41 ;
42 S PSUDVN=0
43 F S PSUDVN=$O(^TMP($J,"FILL",PSUDVN)) Q:PSUDVN="" D
44 .S X=PSUDVN,DIC=59,DIC(0)="XM" D ^DIC ;Find division name
45 .S X=+Y,PSUDIVNM=$$VAL^PSUTL(59,X,.01)
46 .I '$G(PSUDIVNM) S X=PSUDVN,DIC=40.8,DIC(0)="X",D="C" D IX^DIC D
47 ..S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
48 .D VAR
49 .D UNADCST
50 .D FILL
51 .D TOTAL1
52 .;
53 .;Construct line with spacing
54 .S PSULINE=""
55 .S $E(PSULINE,1,17)=PSUDIVNM
56 .S $E(PSULINE,18,28)=$J(FILL30,11)
57 .S $E(PSULINE,29,39)=$J(FILL60,11)
58 .S $E(PSULINE,40,50)=$J(FILL90,11)
59 .S $E(PSULINE,51,61)=$J(UNAD,11)
60 .S $E(PSULINE,62,72)=$J(EQUIV,11)
61 .S $E(PSULINE,74,75)="$"
62 .S $E(PSULINE,76,88)=$J(TCOST(PSUDVN),13)
63 .S $E(PSULINE,90,91)="$"
64 .S $E(PSULINE,92,102)=$J(UNADC(PSUDVN),11)
65 .S $E(PSULINE,104,105)="$"
66 .S $E(PSULINE,106,116)=$J(CFILL(PSUDVN),11)
67 .;End line
68 .S AMIS(PSULN)=PSULINE S PSULN=PSULN+1
69 ;
70 S $P(AMIS(PSULN),"-",132)="" S PSULN=PSULN+1 ;Separator bar
71 ;
72 ;Construct line with spacing
73 S PSULINE=""
74 S $E(PSULINE,1,17)="Total"
75 S $E(PSULINE,18,28)=$J(PSU30,11)
76 S $E(PSULINE,29,39)=$J(PSU60,11)
77 S $E(PSULINE,40,50)=$J(PSU90,11)
78 S $E(PSULINE,51,61)=$J(PSUNADJ,11)
79 S $E(PSULINE,62,72)=$J(PSUEQ,11)
80 S $E(PSULINE,74,75)="$"
81 S $E(PSULINE,76,88)=$J(PSUTCST,13)
82 S $E(PSULINE,90,91)="$"
83 S $E(PSULINE,92,102)=$J(PSUNADC,11)
84 S $E(PSULINE,104,105)="$"
85 S $E(PSULINE,106,116)=$J(PSUCFIL,11)
86 ;End line construction
87 ;
88 S AMIS(PSULN)=PSULINE S PSULN=PSULN+1
89 ;
90 F PSULN=PSULN:1:(PSULN+2) S AMIS(PSULN)="" ;Blank lines
91 S PSULN=PSULN+1
92 ;
93 S AMIS(PSULN)="Unadjusted New Ref Win Mail CMOP Local Staff Fee" S PSULN=PSULN+1
94 ;
95 S AMIS(PSULN)="Division Rx Rx Rx(CS) Rx(CS) Rx Rx(CS) Rx Rx" S PSULN=PSULN+1
96 ;
97 S $P(AMIS(PSULN),"-",132)="" S PSULN=PSULN+1 ;Separator bar
98 ;
99 S PSUDVN=0
100 F S PSUDVN=$O(^TMP($J,"NEW",PSUDVN)) Q:PSUDVN="" D
101 .S X=PSUDVN,DIC=59,DIC(0)="XM" D ^DIC ;Find division name
102 .S X=+Y,PSUDIVNM=$$VAL^PSUTL(59,X,.01)
103 .I '$G(PSUDIVNM) S X=PSUDVN,DIC=40.8,DIC(0)="X",D="C" D IX^DIC D
104 ..S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
105 .D VAR2
106 .D TOTAL2
107 .;Construct line with spacing
108 .S PSULINE=""
109 .S $E(PSULINE,1,17)=PSUDIVNM
110 .S $E(PSULINE,18,27)=$J(PSUN,10)
111 .S $E(PSULINE,28,37)=$J(PSUR,10)
112 .S $E(PSULINE,38,47)=$J(PSUW,10)
113 .S $E(PSULINE,48,57)="("_PSUWCS_")"
114 .S $E(PSULINE,58,67)=$J(PSUM,10)
115 .S $E(PSULINE,68,77)="("_PSUMCS_")"
116 .S $E(PSULINE,78,87)=$J(PSUMOP,10)
117 .S $E(PSULINE,88,97)=$J(PSULOC,10)
118 .S $E(PSULINE,98,107)="("_PSULCS_")"
119 .S $E(PSULINE,108,117)=$J(PSUTF,10)
120 .S $E(PSULINE,118,127)=$J(PSUFE,10)
121 .;End construction of line
122 .S AMIS(PSULN)=PSULINE S PSULN=PSULN+1
123 ;
124 S $P(AMIS(PSULN),"-",132)="" S PSULN=PSULN+1 ;Separator bar
125 ;
126 ;Construct line with spacing
127 S PSULINE=""
128 S $E(PSULINE,1,15)="Total"
129 S $E(PSULINE,18,27)=$J(PSUNEW,10)
130 S $E(PSULINE,28,37)=$J(PSUREF,10)
131 S $E(PSULINE,38,47)=$J(PSUWN,10)
132 S $E(PSULINE,48,57)="("_PSUWNCS_")"
133 S $E(PSULINE,58,67)=$J(PSUML,10)
134 S $E(PSULINE,68,77)="("_PSUMLCS_")"
135 S $E(PSULINE,78,87)=$J(PSUMP,10)
136 S $E(PSULINE,88,97)=$J(PSULC,10)
137 S $E(PSULINE,98,107)="("_PSULOCS_")"
138 S $E(PSULINE,108,117)=$J(PSUSTF,10)
139 S $E(PSULINE,118,127)=$J(PSUFEE,10)
140 ;End construction of line
141 S AMIS(PSULN)=PSULINE S PSULN=PSULN+1
142 ;
143 Q
144 ;
145VAR ;Set contents of ^TMP global into VARIABLES
146 ;
147 S (FILL30,FILL60,FILL90,UNAD,EQUIV)=""
148 ;
149 S FILL30=^TMP($J,"FILL",PSUDVN,30) ;30 DAY FILLS
150 ;
151 S FILL60=^TMP($J,"FILL",PSUDVN,60) ;60 DAY FILLS
152 ;
153 S FILL90=^TMP($J,"FILL",PSUDVN,90) ;90 DAY FILLS
154 ;
155 S UNAD=^TMP($J,"UNAD",PSUDVN) ;UNADJUSTED TOTAL FILLS
156 ;
157 S EQUIV=^TMP($J,"EQUIV",PSUDVN) ;30 DAY EQUIV FILLS
158 ;
159 Q
160 ;
161TCOST ;Calculate total cost for prescription fills
162 ;
163 S PSUTC="",PSUTCOST=""
164 ;
165 S PSUDIVN=0
166 F S PSUDIVN=$O(^TMP($J,"COST",PSUDIVN)) Q:PSUDIVN="" D
167 .S PSURXIEN=0
168 .F S PSURXIEN=$O(^TMP($J,"COST",PSUDIVN,PSURXIEN)) Q:PSURXIEN="" D
169 ..S PSUTCOST=^TMP($J,"COST",PSUDIVN,PSURXIEN)
170 ..S TCOST(PSUDIVN)=$G(TCOST(PSUDIVN))+PSUTCOST
171 ..I TCOST(PSUDIVN)'["." S TCOST(PSUDIVN)=TCOST(PSUDIVN)_".00" Q
172 ..N A,B,C
173 ..S A=$F(TCOST(PSUDIVN),".") ;Find 1st position after decimal
174 ..S B=$E(TCOST(PSUDIVN),1,(A-1)) ;Extract dollars and decimal
175 ..S C=$E(TCOST(PSUDIVN),A,(A+1)) ;Extract cents after decimal
176 ..I $L(C)'=2 S C=$E(C,1)_0
177 ..S TCOST(PSUDIVN)=B_C
178 ;
179 Q
180 ;
181UNADCST ;Calculate Cost Per Unadjusted Fill
182 ;
183 N A,B,C
184 S UNADC(PSUDVN)=TCOST(PSUDVN)/UNAD
185 ;
186 I UNADC(PSUDVN)'["." S UNADC(PSUDVN)=UNADC(PSUDVN)_".00" Q
187 ;
188 S A=$F(UNADC(PSUDVN),".") ;Find position of 1st # after decimal
189 ;
190 S B=$E(UNADC(PSUDVN),1,(A-1)) ;Extract "dollars" up to decimal
191 ;
192 S C=$E(UNADC(PSUDVN),A,(A+1)) ;Extract "cents" after decimal
193 ;
194 S UNADC(PSUDVN)=B_C
195 Q
196 ;
197FILL ;Calculate Cost Per 30-day Fill
198 ;
199 N A,B,C
200 S CFILL(PSUDVN)=TCOST(PSUDVN)/EQUIV
201 ;
202 I CFILL(PSUDVN)'["." S CFILL(PSUDVN)=CFILL(PSUDVN)_".00" Q
203 ;
204 S A=$F(CFILL(PSUDVN),".") ;Find position of 1st # after decimal
205 ;
206 S B=$E(CFILL(PSUDVN),1,(A-1)) ;Extract "dollars" up to decimal
207 ;
208 S C=$E(CFILL(PSUDVN),A,(A+1)) ;Extract "cents" after decimal
209 ;
210 S CFILL(PSUDVN)=B_C
211 ;
212 Q
213 ;
214VAR2 ;Set contents of ^TMP globals into variables
215 ;
216 S (PSUN,PSUR,PSUW,PSUWCS,PSUM,PSUMCS)=""
217 S (PSUMOP,PSULOC,PSULCS,PSUTF,PSUFE)=""
218 ;
219 S PSUN=^TMP($J,"NEW",PSUDVN) ;NEW FILLS
220 ;
221 S PSUR=^TMP($J,"REF",PSUDVN) ;REFILLS
222 ;
223 S PSUW=^TMP($J,"WIN",PSUDVN) ;WINDOW FILLS
224 ;
225 S PSUWCS=^TMP($J,"WINCS",PSUDVN) ;WINDOW CS
226 ;
227 S PSUM=^TMP($J,"MAIL",PSUDVN) ;MAIL FILLS
228 ;
229 S PSUMCS=^TMP($J,"MAILCS",PSUDVN) ;MAIL CS
230 ;
231 S PSUMOP=^TMP($J,"CMOP",PSUDVN) ;CMOP FILLS
232 ;
233 S PSULOC=^TMP($J,"LOC",PSUDVN) ;LOCAL FILLS
234 ;
235 S PSULCS=^TMP($J,"LOCS",PSUDVN) ;LOCAL CS
236 ;
237 S PSUTF=^TMP($J,"STAFF",PSUDVN) ;STAFF FILLS
238 ;
239 S PSUFE=^TMP($J,"FEE",PSUDVN) ;FEE FILLS
240 ;
241 Q
242 ;
243TOTAL1 ;Add each column to get totals for all divisions
244 ;
245 ;
246 S PSU30=$G(PSU30)+FILL30 ;Total 30 day fills
247 ;
248 S PSU60=$G(PSU60)+FILL60 ;Total 60 day fills
249 ;
250 S PSU90=$G(PSU90)+FILL90 ;Total 90 day fills
251 ;
252 S PSUNADJ=$G(PSUNADJ)+UNAD ;Total unadjusted fills
253 ;
254 S PSUEQ=$G(PSUEQ)+EQUIV ;Total 30 day equiv fills
255 ;
256 S PSUTCST=$G(PSUTCST)+TCOST(PSUDVN) ;Total of Total Cost
257 ;
258 ;S PSUNADC=$G(PSUNADC)+UNADC(PSUDVN) ;Total of Cost/Unadj fill
259 I $G(PSUNADJ) S PSUNADC=$G(PSUTCST)/PSUNADJ D
260 .I PSUNADC'["." S PSUNADC=PSUNADC_".00" Q
261 .N A,B,C
262 .S A=$F(PSUNADC,".") ;Find 1st position after decimal
263 .S B=$E(PSUNADC,1,(A-1)) ;Extract dollars and decimal
264 .S C=$E(PSUNADC,A,(A+1)) ;Extract cents after decimal
265 .I $L(C)'=2 S C=$E(C,1)_0
266 .S PSUNADC=B_C
267 ;
268 ;S PSUCFIL=$G(PSUCFIL)+CFILL(PSUDVN) ;Total of Cost/30day fill
269 I $G(PSUEQ) S PSUCFIL=$G(PSUTCST)/PSUEQ D
270 .I PSUCFIL'["." S PSUCFIL=PSUCFIL_".00" Q
271 .N A,B,C
272 .S A=$F(PSUCFIL,".") ;Find 1st position after decimal
273 .S B=$E(PSUCFIL,1,(A-1)) ;Extract dollars and decimal
274 .S C=$E(PSUCFIL,A,(A+1)) ;Extract cents after decimal
275 .I $L(C)'=2 S C=$E(C,1)_0
276 .S PSUCFIL=B_C
277 ;
278 Q
279 ;
280TOTAL2 ;Add each column to get totals for all divisions
281 ;
282 S PSUNEW=$G(PSUNEW)+^TMP($J,"NEW",PSUDVN)
283 ;
284 S PSUREF=$G(PSUREF)+^TMP($J,"REF",PSUDVN)
285 ;
286 S PSUWN=$G(PSUWN)+^TMP($J,"WIN",PSUDVN)
287 ;
288 S PSUWNCS=$G(PSUWNCS)+^TMP($J,"WINCS",PSUDVN)
289 ;
290 S PSUML=$G(PSUML)+^TMP($J,"MAIL",PSUDVN)
291 ;
292 S PSUMLCS=$G(PSUMLCS)+^TMP($J,"MAILCS",PSUDVN)
293 ;
294 S PSUMP=$G(PSUMP)+^TMP($J,"CMOP",PSUDVN)
295 ;
296 S PSULC=$G(PSULC)+^TMP($J,"LOC",PSUDVN)
297 ;
298 S PSULOCS=$G(PSULOCS)+^TMP($J,"LOCS",PSUDVN)
299 ;
300 S PSUSTF=$G(PSUSTF)+^TMP($J,"STAFF",PSUDVN)
301 ;
302 S PSUFEE=$G(PSUFEE)+^TMP($J,"FEE",PSUDVN)
303 ;
304 Q
305 ;
306MAIL ;Send AMIS summary mailman message
307 ;
308 ;Do not send report if option selection includes 1,2,3,4,6
309 I $D(^XTMP("PSU_"_PSUJOB,"CBAMIS")) D Q
310 .M ^XTMP("PSU_"_PSUJOB,"OPCOMBO")=AMIS
311 .S ^XTMP("PSU_"_PSUJOB,"OPCOMBO",1)="OUTPATIENT:"
312 ;
313 S XMSUB="V. 4.0 PBMOP "_PSUMON_" "_PSUST_" "_PSUSTNM
314 S XMTEXT="AMIS("
315 M ^XTMP("PSU_"_PSUJOB,"OPAMIS")=AMIS
316 S XMCHAN=1
317 M XMY=PSUXMYS2
318 D ^XMD
319 ;
320 Q
Note: See TracBrowser for help on using the repository browser.