source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUAR6.m@ 1805

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1PSUAR6 ;BIR/DAM - AR/WS AMIS Summary Data;11 March 2004
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**6**;MARCH, 2005
3 ;
4 ;This routine gathers AR/WS DOSES AMIS Summary data
5 ;No DBIA's needed
6 ;
7EN ;Entry point to gather AMIS data. Called from PSUAR0
8 K PSUAR ;Arrays to hold temporary data
9 N TRUNC,TOT,NET
10 S PSUDV=0
11 F S PSUDV=$O(^XTMP(PSUARSUB,"RECORDS",PSUDV)) Q:PSUDV="" D
12 .S PSUCT=0
13 .F S PSUCT=$O(^XTMP(PSUARSUB,"RECORDS",PSUDV,PSUCT)) Q:PSUCT="" D
14 ..K PSUAMIS
15 ..M PSUAMIS(PSUDV,PSUCT)=^XTMP(PSUARSUB,"RECORDS",PSUDV,PSUCT)
16 ..S PSUCAT=""
17 ..S PSUCAT=$P($G(PSUAMIS(PSUDV,PSUCT)),U,14) ;AMIS Category
18 ..D DSP
19 ..D RET
20 ..D NET
21 ..D TCOST
22 .D AVE
23 D TOTAL
24 D EN^PSUAR7 ;Compose and send MailMan message
25 Q
26DSP ;Calculate AR/WS dispensed data
27 N DSP,DUNT,DFLD,DBLD
28 I PSUCAT="03 or 04" D ;Doses Data
29 .S DSP=$P($G(PSUAMIS(PSUDV,PSUCT)),U,19)
30 .I DSP="" S DSP=0
31 .S $P(PSUAR("DSP",PSUDV),U,1)=$P($G(PSUAR("DSP",PSUDV)),U,1)+DSP
32 ;
33 I PSUCAT="06 or 07" D ;Units Data
34 .S DUNT=$P($G(PSUAMIS(PSUDV,PSUCT)),U,19)
35 .S:DUNT="" DUNT=0
36 .S $P(PSUAR("UNIT",PSUDV),U,1)=$P($G(PSUAR("UNIT",PSUDV)),U,1)+DUNT
37 ;
38 I PSUCAT=17 D ;Fluids/sets data
39 .S DFLD=$P($G(PSUAMIS(PSUDV,PSUCT)),U,19)
40 .S:DFLD="" DFLD=0
41 .S $P(PSUAR("FLD",PSUDV),U,1)=$P($G(PSUAR("FLD",PSUDV)),U,1)+DFLD
42 ;
43 I PSUCAT=22 D ;Blood products data
44 .S DBLD=$P($G(PSUAMIS(PSUDV,PSUCT)),U,19)
45 .S:DBLD="" DBLD=0
46 .S $P(PSUAR("BLD",PSUDV),U,1)=$P($G(PSUAR("BLD",PSUDV)),U,1)+DBLD
47 Q
48RET ;Calculate AR/WS returned data
49 N RET,RUNT,RFLD,RBLD
50 I PSUCAT="03 or 04" D ;Doses data
51 .S RET=$P($G(PSUAMIS(PSUDV,PSUCT)),U,20)
52 .I RET="" S RET=0
53 .S $P(PSUAR("DSP",PSUDV),U,2)=$P($G(PSUAR("DSP",PSUDV)),U,2)+RET
54 ;
55 I PSUCAT="06 or 07" D ;Unit data
56 .S RUNT=$P($G(PSUAMIS(PSUDV,PSUCT)),U,20)
57 .I RUNT="" S RUNT=0
58 .S $P(PSUAR("UNIT",PSUDV),U,2)=$P($G(PSUAR("UNIT",PSUDV)),U,2)+RUNT
59 ;
60 I PSUCAT=17 D ;Fluids/sets data
61 .S RFLD=$P($G(PSUAMIS(PSUDV,PSUCT)),U,20)
62 .I RFLD="" S RFLD=0
63 .S $P(PSUAR("FLD",PSUDV),U,2)=$P($G(PSUAR("FLD",PSUDV)),U,2)+RFLD
64 ;
65 I PSUCAT=22 D ;Blood products data
66 .S RBLD=$P($G(PSUAMIS(PSUDV,PSUCT)),U,20)
67 .I RBLD="" S RBLD=0
68 .S $P(PSUAR("BLD",PSUDV),U,2)=$P($G(PSUAR("BLD",PSUDV)),U,2)+RBLD
69 Q
70NET ;Calculate Net dispensed data
71 I PSUCAT="03 or 04" D ;Doses data
72 .S $P(PSUAR("DSP",PSUDV),U,3)=$P(PSUAR("DSP",PSUDV),U,1)-$P(PSUAR("DSP",PSUDV),U,2)
73 ;
74 I PSUCAT="06 or 07" D ;Unit data
75 .S $P(PSUAR("UNIT",PSUDV),U,3)=$P(PSUAR("UNIT",PSUDV),U,1)-$P(PSUAR("UNIT",PSUDV),U,2)
76 ;
77 I PSUCAT=17 D ;Fluids/sets data
78 .S $P(PSUAR("FLD",PSUDV),U,3)=$P(PSUAR("FLD",PSUDV),U,1)-$P(PSUAR("FLD",PSUDV),U,2)
79 ;
80 I PSUCAT=22 D ;Blood products data
81 .S $P(PSUAR("BLD",PSUDV),U,3)=$P(PSUAR("BLD",PSUDV),U,1)-$P(PSUAR("BLD",PSUDV),U,2)
82 Q
83TCOST ;Calculate total cost
84 N T1,T2
85 S PSUCA=0
86 F S PSUCA=$O(^XTMP("PSUTCST",PSUDV,PSUCA)) Q:PSUCA="" D
87 .I (PSUCA="03")!(PSUCA="04") D
88 ..S T1=$G(^XTMP("PSUTCST",PSUDV,"03"))
89 ..S T2=$G(^XTMP("PSUTCST",PSUDV,"04"))
90 ..S $P(PSUAR("DSP",PSUDV),U,4)=T1+T2
91 ..K T1,T2
92 .I (PSUCA="06")!(PSUCA="07") D
93 ..S T1=$G(^XTMP("PSUTCST",PSUDV,"06"))
94 ..S T2=$G(^XTMP("PSUTCST",PSUDV,"07"))
95 ..S $P(PSUAR("UNIT",PSUDV),U,4)=T1+T2
96 ..K T1,T2
97 .I PSUCA=17 D
98 ..S $P(PSUAR("FLD",PSUDV),U,4)=^XTMP("PSUTCST",PSUDV,PSUCA)
99 .I PSUCA=22 D
100 ..Q:$P($G(PSUAR("BLD",PSUDV)),U,1)=""
101 ..S $P(PSUAR("BLD",PSUDV),U,4)=^XTMP("PSUTCST",PSUDV,PSUCA)
102 Q
103AVE ;Calculate Average cost per dose
104 N NET,TOT
105 S NET=$P($G(PSUAR("DSP",PSUDV)),U,3)
106 I $G(NET)'>0 S NET=1
107 S TOT=$P($G(PSUAR("DSP",PSUDV)),U,4)
108 S $P(PSUAR("DSP",PSUDV),U,5)=TOT/NET D
109 .S TRUNC=PSUAR("DSP",PSUDV) ;transfer node to variable
110 .D TRUNC
111 .S PSUAR("DSP",PSUDV)=TRUNC ;transfer node back to array
112 .K TRUNC
113 .K TOT,NET
114 ;
115 I $D(PSUAR("UNIT",PSUDV)) D
116 .S NET=$P(PSUAR("UNIT",PSUDV),U,3)
117 .I $G(NET)'>0 S NET=1
118 .S TOT=$P($G(PSUAR("UNIT",PSUDV)),U,4)
119 .S $P(PSUAR("UNIT",PSUDV),U,5)=TOT/NET D
120 ..S TRUNC=PSUAR("UNIT",PSUDV) ;transfer node to variable
121 ..D TRUNC
122 ..S PSUAR("UNIT",PSUDV)=TRUNC ;transfer node back to array
123 ..K TRUNC
124 ..K TOT,NET
125 I '$D(PSUAR("UNIT",PSUDV)) D
126 .S PSUAR("UNIT",PSUDV)="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
127 ;
128 I $D(PSUAR("FLD",PSUDV)) D
129 .S NET=$P($G(PSUAR("FLD",PSUDV)),U,3)
130 .I $G(NET)'>0 S NET=1
131 .S TOT=$P($G(PSUAR("FLD",PSUDV)),U,4)
132 .S $P(PSUAR("FLD",PSUDV),U,5)=TOT/NET D
133 ..S TRUNC=PSUAR("FLD",PSUDV) ;transfer node to variable
134 ..D TRUNC
135 ..S PSUAR("FLD",PSUDV)=TRUNC ;transfer node back to array
136 ..K TRUNC
137 ..K TOT,NET
138 I '$D(PSUAR("FLD",PSUDV)) D
139 .S PSUAR("FLD",PSUDV)="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
140 ;
141 I $D(PSUAR("BLD",PSUDV)),$G(PSUDIV) D
142 .S NET=$P(PSUAR("BLD",PSUDV),U,3)
143 .I $G(NET)'>0 S NET=1
144 .S TOT=$P($G(PSUAR("BLD",PSUDV)),U,4)
145 .S $P(PSUAR("BLD",PSUDV),U,5)=TOT/NET D
146 ..S TRUNC=PSUAR("BLD",PSUDV) ;transfer node to variable
147 ..D TRUNC
148 ..S PSUAR("BLD",PSUDV)=TRUNC ;transfer node back to array
149 ..K TRUNC
150 ..K TOT,NET
151 I '$D(PSUAR("BLD",PSUDV)) D
152 .S PSUAR("BLD",PSUDV)="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
153 Q
154TRUNC ;Truncate pieces with dollar values to 2 decimal places
155 ;
156 F I=1:1:5 D
157 .N A,B,C
158 .I $P(TRUNC,U,I)'["." D Q
159 ..S $P(TRUNC,U,I)=$P(TRUNC,U,I)_".00"
160 .S A=$F($P(TRUNC,U,I),".") ;Find first position after decimal
161 .S B=$E($P(TRUNC,U,I),1,(A-1)) ;Extract dollars and decimal
162 .S C=$E($P(TRUNC,U,I),A,(A+1)) ;Extract cents after decimal
163 .I $L(C)'=2 S C=$E(C,1)_0
164 .S $P(TRUNC,U,I)=B_C
165 Q
166TOTAL ;Calculate column totals for each division
167 ;
168 I $D(PSUAR("DSP")) D
169 .N TDSP,TRET,TNET,TCST,TAVE
170 .S PSUDIV=0 ;Doses data
171 .F S PSUDIV=$O(PSUAR("DSP",PSUDIV)) Q:PSUDIV="" D
172 ..S TDSP=$G(TDSP)+$P(PSUAR("DSP",PSUDIV),U,1) ;Total dispensed
173 ..S TRET=$G(TRET)+$P(PSUAR("DSP",PSUDIV),U,2) ;Total returned
174 ..S TNET=$G(TNET)+$P(PSUAR("DSP",PSUDIV),U,3) ;Total of Net
175 ..S TCST=$G(TCST)+$P(PSUAR("DSP",PSUDIV),U,4) ;Total of total costs
176 ..I $G(TNET) S TAVE=$G(TCST)/TNET D
177 ...I TAVE'["." S TAVE=TAVE_".00" Q
178 ...N A,B,C
179 ...S A=$F(TAVE,".") ;Find 1st position after decimal
180 ...S B=$E(TAVE,1,(A-1)) ;Extract dollars and decimal
181 ...S C=$E(TAVE,A,(A+1)) ;Extract cents after decimal
182 ...I $L(C)'=2 S C=$E(C,1)_0
183 ...S TAVE=B_C
184 ..I '$D(TAVE) S TAVE="0.00"
185 .;
186 .S TOTAL("DSP")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE D
187 ..S TRUNC=TOTAL("DSP") ;Transfer to variable
188 ..D TRUNC
189 ..S TOTAL("DSP")=TRUNC ;Transfer back to array
190 ..K TRUNC
191 ;
192 I $D(PSUAR("UNIT")) D
193 .N TDSP,TRET,TNET,TCST,TAVE
194 .S PSUDIV=0 ;Unit data
195 .F S PSUDIV=$O(PSUAR("UNIT",PSUDIV)) Q:PSUDIV="" D
196 ..S TDSP=$G(TDSP)+$P(PSUAR("UNIT",PSUDIV),U,1) ;Total dispensed
197 ..S TRET=$G(TRET)+$P(PSUAR("UNIT",PSUDIV),U,2) ;Total returned
198 ..S TNET=$G(TNET)+$P(PSUAR("UNIT",PSUDIV),U,3) ;Total of Net
199 ..S TCST=$G(TCST)+$P(PSUAR("UNIT",PSUDIV),U,4) ;Total of total costs
200 ..I $G(TNET) S TAVE=$G(TCST)/TNET D
201 ...I TAVE'["." S TAVE=TAVE_".00" Q
202 ...N A,B,C
203 ...S A=$F(TAVE,".") ;Find 1st position after decimal
204 ...S B=$E(TAVE,1,(A-1)) ;Extract dollars and decimal
205 ...S C=$E(TAVE,A,(A+1)) ;Extract cents after decimal
206 ...I $L(C)'=2 S C=$E(C,1)_0
207 ...S TAVE=B_C
208 ..I '$D(TAVE) S TAVE="0.00"
209 .S TOTAL("UNIT")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE D
210 ..S TRUNC=TOTAL("UNIT") ;Transfer to variable
211 ..D TRUNC
212 ..S TOTAL("UNIT")=TRUNC ;Transfer back to array
213 ..K TRUNC
214 ;
215 I $D(PSUAR("FLD")) D
216 .N TDSP,TRET,TNET,TCST,TAVE
217 .S PSUDIV=0 ;Fluid/sets data
218 .F S PSUDIV=$O(PSUAR("FLD",PSUDIV)) Q:PSUDIV="" D
219 ..S TDSP=$G(TDSP)+$P(PSUAR("FLD",PSUDIV),U,1) ;Total dispensed
220 ..S TRET=$G(TRET)+$P(PSUAR("FLD",PSUDIV),U,2) ;Total returned
221 ..S TNET=$G(TNET)+$P(PSUAR("FLD",PSUDIV),U,3) ;Total of Net
222 ..S TCST=$G(TCST)+$P(PSUAR("FLD",PSUDIV),U,4) ;Total of total costs
223 ..I $G(TNET) S TAVE=$G(TCST)/TNET D
224 ...I TAVE'["." S TAVE=TAVE_".00" Q
225 ...N A,B,C
226 ...S A=$F(TAVE,".") ;Find 1st position after decimal
227 ...S B=$E(TAVE,1,(A-1)) ;Extract dollars and decimal
228 ...S C=$E(TAVE,A,(A+1)) ;Extract cents after decimal
229 ...I $L(C)'=2 S C=$E(C,1)_0
230 ...S TAVE=B_C
231 ..I '$D(TAVE) S TAVE="0.00"
232 .S TOTAL("FLD")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE D
233 ..S TRUNC=TOTAL("FLD") ;Transfer to variable
234 ..D TRUNC
235 ..S TOTAL("FLD")=TRUNC ;Transfer back to array
236 ..K TRUNC
237 I '$D(PSUAR("FLD")) D
238 .S TOTAL("FLD")="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
239 ;
240 ;
241 I $D(PSUAR("BLD")) D
242 .N TDSP,TRET,TNET,TCST,TAVE
243 .S PSUDIV=0 ;Blood data
244 .F S PSUDIV=$O(PSUAR("BLD",PSUDIV)) Q:PSUDIV="" D
245 ..S TDSP=$G(TDSP)+$P(PSUAR("BLD",PSUDIV),U,1) ;Total dispensed
246 ..S TRET=$G(TRET)+$P(PSUAR("BLD",PSUDIV),U,2) ;Total returned
247 ..S TNET=$G(TNET)+$P(PSUAR("BLD",PSUDIV),U,3) ;Total of Net
248 ..S TCST=$G(TCST)+$P(PSUAR("BLD",PSUDIV),U,4) ;Total of total costs
249 ..I $G(TNET) S TAVE=$G(TCST)/TNET D
250 ...I TAVE'["." S TAVE=TAVE_".00" Q
251 ...N A,B,C
252 ...S A=$F(TAVE,".") ;Find 1st position after decimal
253 ...S B=$E(TAVE,1,(A-1)) ;Extract dollars and decimal
254 ...S C=$E(TAVE,A,(A+1)) ;Extract cents after decimal
255 ...I $L(C)'=2 S C=$E(C,1)_0
256 ...S TAVE=B_C
257 ..I '$D(TAVE) S TAVE="0.00"
258 .S TOTAL("BLD")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE D
259 ..S TRUNC=TOTAL("BLD") ;Transfer to variable
260 ..D TRUNC
261 ..S TOTAL("BLD")=TRUNC ;Transfer back to array
262 ..K TRUNC
263 I '$D(PSUAR("BLD")) D
264 .S TOTAL("BLD")="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
265 Q
Note: See TracBrowser for help on using the repository browser.