source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUSUM6.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1PSUSUM6 ;BIR/DAM - Patient Demographics Summary for IV/UD/RX ; 20 DEC 2001
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4EN ;EN CALLED FROM PSUOP0
5 ;
6 K ^XTMP("PSU_"_PSUJOB,"PSUSUMA") ;DAM Trying to make auto run
7 I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG2"))!$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG3")) D
8 .K ^XTMP("PSU_"_PSUJOB,"PSUSUMA")
9 ;
10 N PSURX,PSUIV,PSUUD
11 S PSURX=$G(^XTMP("PSU_"_PSUJOB,"PSUNONE","RX"))
12 S PSUIV=$G(^XTMP("PSU_"_PSUJOB,"PSUNONE","IV"))
13 S PSUUD=$G(^XTMP("PSU_"_PSUJOB,"PSUNONE","UD"))
14 I $G(PSURX)&$G(PSUIV)&$G(PSUUD) D Q
15 .D NODATA D
16 ..I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG1"))!$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG2")) K ^XTMP("PSU_"_PSUJOB,"PSUNONE")
17 D EN1
18 Q
19 ;
20EN1 ;Gather summary data for UD/IV/RX report
21 D PULL^PSUCP
22 D DATE
23 S I=7
24 D UNIQUE
25 D TOP
26 D OPDIV
27 D DIVTOT
28 D TUDIV
29 D IPDIV
30 D IPDIV1
31 D TAB3
32 D TAB4
33 D PDSUM^PSUDEM5 ;Mail message
34 K ^XTMP("PSU_"_PSUJOB,"PSUTMP")
35 K ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")
36 K ^XTMP("PSU_"_PSUJOB,"PSURXUNIQUE")
37 K ^XTMP("PSU_"_PSUJOB,"PSURXTOTAL")
38 K ^XTMP("PSU_"_PSUJOB,"PSURXCTA")
39 K ^XTMP("PSU_"_PSUJOB,"PSURXSSN")
40 K ^XTMP("PSU_"_PSUJOB,"PSUCOMBO")
41 K ^XTMP("PSU_"_PSUJOB,"PSUIVSSN")
42 K ^XTMP("PSU_"_PSUJOB,"PSUUDSSN")
43 K ^XTMP("PSU_"_PSUJOB,"PSUIVDIV")
44 K ^XTMP("PSU_"_PSUJOB,"PSUIVOUT")
45 K ^XTMP("PSU_"_PSUJOB,"PSUUDDIV")
46 Q
47 ;
48DATE ;EN Convert date range of extract to external format
49 ;
50 S %H=$E($H,1,5) ;today's date
51 D YX^%DTC
52 N PSUD S PSUD=Y
53 ;
54 S Y=PSUSDT
55 D DD^%DT
56 N PSUS S PSUS=Y
57 ;
58 S Y=PSUEDT
59 D DD^%DT
60 N PSUE S PSUE=Y
61 ;
62 D COMSUM
63 Q
64 ;
65COMSUM ;Summary report header to be run for combination Rx/IV/UD report
66 ;
67 ;Report header
68 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY UNIQUE PATIENTS REPORT "_PSUD
69 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",2),"-",80)="" ;Separator bar
70 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)=" "_PSUS_" through "_PSUE
71 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",4),"=",80)=""
72 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",5)=" UNIQUE"
73 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",6),"-",70)=""
74 Q
75 ;
76UNIQUE ;Find total unique pharmacy patients across all divisions
77 ;
78 S PSURXN=0,PSUIVN=0,PSUUDN1=0
79 ;
80 M ^XTMP("PSU_"_PSUJOB,"PSUTMP")=^XTMP("PSU_"_PSUJOB,"PSURXSSN")
81 M ^XTMP("PSU_"_PSUJOB,"PSUTMP")=^XTMP("PSU_"_PSUJOB,"PSUIVSSN")
82 M ^XTMP("PSU_"_PSUJOB,"PSUTMP")=^XTMP("PSU_"_PSUJOB,"PSUUDSSN")
83 ;
84 ;
85 S N=1
86 S PSUTTL=0
87 F S PSUTTL=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP",PSUTTL)) Q:PSUTTL="" D
88 .S ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")=N S N=N+1
89 D TAB2
90 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",I),"-",70)="" S I=I+1
91 Q
92 ;
93TAB2 ;Tab spacing for line 7. Set line into global
94 ;
95 N PSUTB3,PSUTB4,PSUTB5
96 ;
97 S PSUTB3=" "
98 S PSUTB4="TOTAL Pharmacy patients across all divisions:"
99 S PSUTB5=(64-$L(PSUTB4))-$L($P($G(^XTMP("PSU_"_PSUJOB,"PSUTOTAL")),U,1))
100 F S3=1:1:(PSUTB5-1) S PSUTB(S3)=" " D
101 .S PSUTB3=PSUTB3_PSUTB(S3)
102 I '$G(^XTMP("PSU_"_PSUJOB,"PSUTOTAL")) D
103 .S ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")=0
104 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB4_PSUTB3_$P($G(^XTMP("PSU_"_PSUJOB,"PSUTOTAL")),U,1)
105 S I=I+1
106 Q
107 ;
108TOP ;EN Find Total Outpatients
109 N PSUTB1,PSUTB2
110 ;
111 N PSUTOP,PSULBL
112 S PSUTOP=$G(^XTMP("PSU_"_PSUJOB,"PSURXUNIQUE"))
113 I '$G(PSUTOP) S PSUTOP=0,PSUTOPF=1
114 S PSULBL=" Total OUTPATIENT:"
115 D TAB
116 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSULBL_PSUTB1_PSUTOP S I=I+1
117 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",I),"-",70)="" S I=I+1
118 Q
119 ;
120TAB ;Calculate tab spacing
121 ;
122 S PSUTB1=" "
123 S PSUTB2=(64-$L(PSUTOP))-$L(PSULBL)
124 F S2=1:1:(PSUTB2-1) S PSUTB(S2)=" " D
125 .S PSUTB1=PSUTB1_PSUTB(S2)
126 Q
127 ;
128OPDIV ;EN Find outpatients per division
129 ;
130 Q:$G(PSUTOPF)
131 N PSUTB1,PSUTB2
132 ;
133 N PSUTTL
134 S PSULBL=0
135 I $D(^XTMP("PSU_"_PSUJOB,"PSURXCTA")) D
136 .F S PSULBL=$O(^XTMP("PSU_"_PSUJOB,"PSURXCTA",PSULBL)) Q:PSULBL="" D
137 ..Q:PSULBL=0
138 ..S PSUTTL=$P($G(^XTMP("PSU_"_PSUJOB,"PSURXCTA",PSULBL)),U,1)
139 ..D TAB1
140 ..S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" "_PSULBL_" Division:"_PSUTB1_PSUTTL
141 ..S I=I+1
142 I '$D(^XTMP("PSU_"_PSUJOB,"PSURXCTA")) D
143 .S PSUTTL=0
144 .D TAB1
145 .S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" "_PSULBL_" Division:"_PSUTB1_PSUTTL
146 .S I=I+1
147 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" ----------" S I=I+1
148 Q
149 ;
150TAB1 ;EN Calculate division tab spacing
151 ;
152 S PSUTB1=" "
153 S PSUTB2=(59-$L(PSUTTL))-$L(PSULBL)-10
154 F S2=1:1:(PSUTB2-1) S PSUTB(S2)=" " D
155 .S PSUTB1=PSUTB1_PSUTB(S2)
156 Q
157 ;
158DIVTOT ;EN Calculate tab spacing for 'Outpatient total of all divisions'
159 ;line and set line into message global
160 ;
161 N PSUTB3,PSUTB4,PSUTB5
162 ;
163 I '$G(^XTMP("PSU_"_PSUJOB,"PSURXTOTAL")) D
164 .S ^XTMP("PSU_"_PSUJOB,"PSURXTOTAL")=0
165 S PSUTB3=" "
166 S PSUTB4=" Outpatient Total of all Divisions:"
167 S PSUTB5=(64-$L(PSUTB4))-$L($P($G(^XTMP("PSU_"_PSUJOB,"PSURXTOTAL")),U,1))
168 F S3=1:1:(PSUTB5-1) S PSUTB3(S3)=" " D
169 .S PSUTB3=PSUTB3_PSUTB(S3)
170 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB4_PSUTB3_$P($G(^XTMP("PSU_"_PSUJOB,"PSURXTOTAL")),U,1) S I=I+1
171 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",I),"-",70)="" S I=I+1
172 Q
173 ;
174TUDIV ;Calculate tab spacing for 'Total INPATIENT' line and
175 ;set line into message global
176 ;
177 N PSUTB3,PSUTB4,PSUTB5
178 ;
179 ;Create global with total number of unique UD + IV inpatients
180 ;using patient SSN to ID unique patient
181 M ^XTMP("PSU_"_PSUJOB,"PSUUDIVT")=^XTMP("PSU_"_PSUJOB,"PSUDIV1")
182 M ^XTMP("PSU_"_PSUJOB,"PSUUDIVT")=^XTMP("PSU_"_PSUJOB,"PSUDIVUD")
183 ;
184 ;Loop through division global and create global with unique SSN
185 S G=1
186 S PSUD2=0
187 F S PSUD2=$O(^XTMP("PSU_"_PSUJOB,"PSUUDIVT",PSUD2)) Q:PSUD2="" D
188 .S PSUD8=0
189 .F S PSUD8=$O(^XTMP("PSU_"_PSUJOB,"PSUUDIVT",PSUD2,PSUD8)) Q:PSUD8="" D
190 ..S ^XTMP("PSU_"_PSUJOB,"PSUUDIVT1",PSUD8)="" ;Unique SSN's
191 ;
192 ;Find number of unique SSN's. This is number of unique patients
193 S PSUD9=0
194 F S PSUD9=$O(^XTMP("PSU_"_PSUJOB,"PSUUDIVT1",PSUD9)) Q:PSUD9="" D
195 .S ^XTMP("PSU_"_PSUJOB,"PSUUDIVTOT")=G,G=G+1
196 ;
197 ;Calculate tab spacing
198 S PSUTB3=" "
199 S PSUTB4=" Total INPATIENT:"
200 S PSUTB5=(64-$L(PSUTB4))-$L($P($G(^XTMP("PSU_"_PSUJOB,"PSUUDIVTOT")),U,1))
201 F S3=1:1:(PSUTB5-1) S PSUTB(S3)=" " D
202 .S PSUTB3=PSUTB3_PSUTB(S3) ;Tab position
203 ;
204 ;Set line into message global
205 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB4_PSUTB3_$P($G(^XTMP("PSU_"_PSUJOB,"PSUUDIVTOT")),U,1) S I=I+1
206 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",I),"-",70)="" S I=I+1
207 Q
208 ;
209IPDIV ;EN Find inpatients by division (includes UD patients and IV
210 ;patients with ward location NOT set to 0.5
211 ;
212 ;If no Unit Dose data exists, do the following to get IV data:
213 I $D(^XTMP("PSU_"_PSUJOB,"PSUNONE","UD")) D Q
214 .M ^XTMP("PSU_"_PSUJOB,"PSUINPT")=^XTMP("PSU_"_PSUJOB,"PSUDIV1")
215 ;
216 ;If no IV data exists, do the following to get UD data:
217 I $D(^XTMP("PSU_"_PSUJOB,"PSUNONE","IV")) D Q
218 .M ^XTMP("PSU_"_PSUJOB,"PSUINPT")=^XTMP("PSU_"_PSUJOB,"PSUDIVUD")
219 ;
220 ;Construct a storage global containing unique inpatients
221 ;per division when there is both UD and IV data
222 S PSUDV1=0
223 F S PSUDV1=$O(^XTMP("PSU_"_PSUJOB,"PSUDIV1",PSUDV1)) Q:PSUDV1="" D
224 .S PSUDVUD=0
225 .F S PSUDVUD=$O(^XTMP("PSU_"_PSUJOB,"PSUDIVUD",PSUDVUD)) Q:PSUDVUD="" D
226 ..I PSUDVUD=PSUDV1 D
227 ...S PSUPT=0
228 ...F S PSUPT=$O(^XTMP("PSU_"_PSUJOB,"PSUDIV1",PSUDV1,PSUPT)) Q:PSUPT="" D
229 ....S ^XTMP("PSU_"_PSUJOB,"PSUINPT",PSUDV1,PSUPT)=""
230 ....S PSUPT1=0
231 ....F S PSUPT1=$O(^XTMP("PSU_"_PSUJOB,"PSUDIVUD",PSUDVUD,PSUPT1)) Q:PSUPT1="" D
232 .....S ^XTMP("PSU_"_PSUJOB,"PSUINPT",PSUDVUD,PSUPT1)=""
233 ..I PSUDVUD'=PSUDV1 D
234 ...M ^XTMP("PSU_"_PSUJOB,"PSUINPT")=^XTMP("PSU_"_PSUJOB,"PSUDIVUD")
235 Q
236 ;
237IPDIV1 ;Calculate inpatient totals
238 ;
239 S PSUSIT=0,PSUSIT1=0,T=1
240 ;
241 F S PSUSIT=$O(^XTMP("PSU_"_PSUJOB,"PSUINPT",PSUSIT)) Q:PSUSIT="" D
242 .F S PSUSIT1=$O(^XTMP("PSU_"_PSUJOB,"PSUINPT",PSUSIT,PSUSIT1)) Q:PSUSIT1="" D
243 ..I $D(^XTMP("PSU_"_PSUJOB,"PSUCOMBO",PSUSIT)) D
244 ...S C=C+1
245 ...S ^XTMP("PSU_"_PSUJOB,"PSUCOMBO",PSUSIT)=C
246 ..I '$D(^XTMP("PSU_"_PSUJOB,"PSUCOMBO",PSUSIT)) D
247 ...S C=1
248 ...S ^XTMP("PSU_"_PSUJOB,"PSUCOMBO",PSUSIT)=C
249 Q
250 ;
251TAB3 ;Place inpatient division totals into summary message
252 ;
253 N PSUTB1,PSUTB2
254 ;
255 N PSUTTL
256 S PSULBL=0
257 F S PSULBL=$O(^XTMP("PSU_"_PSUJOB,"PSUCOMBO",PSULBL)) Q:PSULBL="" D
258 .S PSUTTL=$P($G(^XTMP("PSU_"_PSUJOB,"PSUCOMBO",PSULBL)),U,1)
259 .I '$G(PSUTTL) S PSUTTL=0
260 .D TAB1
261 .S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" "_PSULBL_" Division:"_PSUTB1_PSUTTL
262 .S I=I+1
263 Q
264 ;
265TAB4 ;Calculate inpatient totals of all divisions and place in summary
266 ;message
267 ;
268 S N=0,PSUMKER=0
269 F S PSUMKER=$O(^XTMP("PSU_"_PSUJOB,"PSUCOMBO",PSUMKER)) Q:PSUMKER="" D
270 .S N=$P(^XTMP("PSU_"_PSUJOB,"PSUCOMBO",PSUMKER),U)+N
271 S ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")=N ;Sum of all inpatients
272 ;
273 D TAB1^PSUSUM3
274 Q
275 ;
276NODATA ;Summary report line to be sent if there is no data
277 ;
278 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY UNIQUE PATIENTS REPORT"
279 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",2)=" "
280 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)="No data to report"
281 D PDSUM^PSUDEM5
282 Q
Note: See TracBrowser for help on using the repository browser.