source: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUSUM4.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 7.6 KB
Line 
1PSUSUM4 ;BIR/DAM - Patient Demographics Summary for IV Extract ; 20 DEC 2001
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4 ;DBIA's
5 ; Reference to file #55 supported by DBIA 3502
6 ; Reference to file #42 supported by DBIA 2440
7 ;
8EN ;EN CALLED FROM PSUIV0
9 ;Q:$D(^XTMP("PSU_"_PSUJOB,"PSUMFLAG")) ;Do not run if auto extract
10 ;
11 D PULL^PSUCP
12 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
13 ;
14 I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG2"))!$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG3")) K ^XTMP("PSU_"_PSUJOB,"PSUSUMA")
15 I $D(^XTMP("PSU_"_PSUJOB,"PSUNONE","IV")) D Q ;Summary report if there is no data
16 .I '$D(PSUMOD(2))&$D(PSUMOD(1)) D
17 ..I '$D(PSUMOD(4)) D
18 ...D NODATA
19 ...I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG1"))!$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG2")) K ^XTMP("PSU_"_PSUJOB,"PSUNONE")
20 D EN1
21 Q
22 ;
23EN1 ;Entry point to collect data
24 ;
25 D DATE
26 M ^XTMP("PSU_"_PSUJOB,"PSUIV")=^XTMP(PSUIVSUB)
27 S I=7 ;Line counter for message
28 D UNIQUE
29 N PSUTB2,PSUTB3,PSUTB4,PSUTB5
30 D TAB
31 D TOTUN
32 S I=10 ;Reset line counter for message
33 D PATNUM
34 D TAB1
35 ;
36 I $D(PSUMOD(2))&$D(PSUMOD(1)) D
37 .I $D(PSUMOD(4)) D
38 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVINDIV")=^XTMP("PSU_"_PSUJOB,"PSUCT")
39 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVIN")=^XTMP("PSU_"_PSUJOB,"PSUINP")
40 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVOUT")=^XTMP("PSU_"_PSUJOB,"PSUOUTP")
41 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVSSN")=^XTMP("PSU_"_PSUJOB,"PSUIV","PAT")
42 ..M ^XTMP("PSU_"_PSUJOB,"PSUDIV1")=^XTMP("PSU_"_PSUJOB,"PSUDIV")
43 ;
44 I '$D(PSUMOD(2))&$D(PSUMOD(1)) D
45 .I $D(PSUMOD(4)) D
46 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVINDIV")=^XTMP("PSU_"_PSUJOB,"PSUCT")
47 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVIN")=^XTMP("PSU_"_PSUJOB,"PSUINP")
48 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVOUT")=^XTMP("PSU_"_PSUJOB,"PSUOUTP")
49 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVSSN")=^XTMP("PSU_"_PSUJOB,"PSUIV","PAT")
50 ..M ^XTMP("PSU_"_PSUJOB,"PSUIN1")=^XTMP("PSU_"_PSUJOB,"PSUIN")
51 ..M ^XTMP("PSU_"_PSUJOB,"PSUDIV1")=^XTMP("PSU_"_PSUJOB,"PSUDIV")
52 ;
53 I $D(PSUMOD(2))&$D(PSUMOD(1)) D
54 .I '$D(PSUMOD(4)) D
55 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVINDIV")=^XTMP("PSU_"_PSUJOB,"PSUCT")
56 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVIN")=^XTMP("PSU_"_PSUJOB,"PSUINP")
57 ..M ^XTMP("PSU_"_PSUJOB,"PSUIVOUT")=^XTMP("PSU_"_PSUJOB,"PSUOUTP")
58 ..M ^XTMP("PSU_"_PSUJOB,"PSUDIV1")=^XTMP("PSU_"_PSUJOB,"PSUDIV")
59 ;
60 I '$D(PSUMOD(2))&'$D(PSUMOD(4)) D
61 .I '$G(^XTMP("PSU_"_PSUJOB,"PSUFLAG1")) D
62 ..D PDSUM^PSUDEM5 ;Mail message
63 ..K ^XTMP("PSU_"_PSUJOB,"PSUIVOUT")
64 ..K ^XTMP("PSU_"_PSUJOB,"PSUIVINDIV")
65 K ^XTMP("PSU_"_PSUJOB,"PSUIV")
66 ;K ^XTMP("PSU_"_PSUJOB,"PSUIVSSN")
67 K ^XTMP("PSU_"_PSUJOB,"PSUINP")
68 ;K ^XTMP("PSU_"_PSUJOB,"PSUIN")
69 ;K ^XTMP("PSU_"_PSUJOB,"PSUOUT")
70 I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG1")) K ^XTMP("PSU_"_PSUJOB,"PSUSUMA")
71 I $D(^XTMP("PSU_"_PSUJOB,"PSUMFLAG"))
72 K ^XTMP("PSU_"_PSUJOB,"PSUFLAG1")
73 K ^XTMP("PSU_"_PSUJOB,"PSUOUTP")
74 K ^XTMP("PSU_"_PSUJOB,"PSUINP")
75 ;K ^XTMP("PSU_"_PSUJOB,"PSUDIV")
76 K ^XTMP("PSU_"_PSUJOB,"PSUCT")
77 ;K ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")
78 K ^XTMP("PSU_"_PSUJOB,"PSURXCTA")
79 Q
80 ;
81DATE ;Convert date range of extract to external format
82 ;
83 S %H=$E($H,1,5) ;today's date
84 D YX^%DTC
85 N PSUD S PSUD=Y
86 ;
87 S Y=PSUSDT
88 D DD^%DT
89 N PSUS S PSUS=Y
90 ;
91 S Y=PSUEDT
92 D DD^%DT
93 N PSUE S PSUE=Y
94 ;
95 D IVSUM
96 Q
97 ;
98IVSUM ;Summary report header to be run if IV extract is run
99 ;
100 ;Report header
101 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY INPATIENT (IV) UNIQUE PATIENTS REPORT "_PSUD
102 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",2),"-",80)="" ;Separator bar
103 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)=" "_PSUS_" through "_PSUE
104 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",4),"=",80)=""
105 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",5)=" UNIQUE"
106 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",6),"-",70)=""
107 Q
108 ;
109UNIQUE ;Find number of unique patients across all divisions
110 ;
111 N PSUSIT
112 S PSUSIT=PSUSNDR
113 ;
114 N PSUWD,PSUSN
115 S PSUOPCT=1
116 S PSUIPCT=1
117 S PSUNUM=0,PSUSIT1=0
118 F S PSUSIT1=$O(^XTMP("PSU_"_PSUJOB,"PSUIV","RECORDS",PSUSIT1)) Q:PSUSIT1="" D
119 .F S PSUNUM=$O(^XTMP("PSU_"_PSUJOB,"PSUIV","RECORDS",PSUSIT1,PSUNUM)) Q:PSUNUM="" D
120 ..S PSUWD=$P($G(^XTMP("PSU_"_PSUJOB,"PSUIV","RECORDS",PSUSIT1,PSUNUM)),U,7)
121 ..S PSUSN=$P($G(^XTMP("PSU_"_PSUJOB,"PSUIV","RECORDS",PSUSIT1,PSUNUM)),U,8)
122 ..I PSUWD'="" D
123 ...I PSUWD="Y" S ^XTMP("PSU_"_PSUJOB,"PSUOUT",PSUSN)=""
124 ...I PSUWD="N" S ^XTMP("PSU_"_PSUJOB,"PSUIN",PSUSN)=""
125 D WARD
126 Q
127 ;
128WARD ;Find unique number of patients that are OP and IP
129 ;
130 ;Find unique number of outpatients
131 S PSUD1A=0
132 F S PSUD1A=$O(^XTMP("PSU_"_PSUJOB,"PSUOUT",PSUD1A)) Q:PSUD1A="" D
133 .S ^XTMP("PSU_"_PSUJOB,"PSUOUTP")=PSUOPCT S PSUOPCT=PSUOPCT+1
134 ;
135 ;Find unique number in inpatients
136 S PSUD1B=0
137 F S PSUD1B=$O(^XTMP("PSU_"_PSUJOB,"PSUIN",PSUD1B)) Q:PSUD1B="" D
138 .S ^XTMP("PSU_"_PSUJOB,"PSUINP")=PSUIPCT S PSUIPCT=PSUIPCT+1
139 Q
140 ;
141TAB ;Calculate tab spacing
142 ;
143 I '$D(^XTMP("PSU_"_PSUJOB,"PSUINP")) S ^XTMP("PSU_"_PSUJOB,"PSUINP")=0
144 I '$D(^XTMP("PSU_"_PSUJOB,"PSUOUTP")) S ^XTMP("PSU_"_PSUJOB,"PSUOUTP")=0
145 ;
146 S PSUTB1=" "
147 S PSUTB2="Total unique Inpatients across all divisions:"
148 S PSUTB3=(64-$L(^XTMP("PSU_"_PSUJOB,"PSUINP")))-$L(PSUTB2)
149 F S2=1:1:(PSUTB3-1) S PSUTB(S2)=" " D
150 .S PSUTB1=PSUTB1_PSUTB(S2)
151 ;
152 S PSUTB6=" "
153 S PSUTB4="Total unique Outpatients across all divisions:"
154 S PSUTB5=(64-$L(^XTMP("PSU_"_PSUJOB,"PSUOUTP")))-$L(PSUTB4)
155 F S3=1:1:(PSUTB5-1) S PSUTB(S3)=" " D
156 .S PSUTB6=PSUTB6_PSUTB(S3)
157 Q
158 ;
159TOTUN ;Set total number of unique in-patients and out-patients into
160 ;summary message
161 ;
162 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB2_PSUTB1_^XTMP("PSU_"_PSUJOB,"PSUINP") S I=I+1
163 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB4_PSUTB6_^XTMP("PSU_"_PSUJOB,"PSUOUTP") S I=I+1
164 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",I),"-",70)=""
165 Q
166 ;
167PATNUM ;Place division names and patient totals into summary message
168 ;
169 N PSUTB1,PSUTB2
170 N PSUCT3
171 S PSUTOTAL=0
172 S PSUDIVNM=0
173 F S PSUDIVNM=$O(^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIVNM)) Q:PSUDIVNM="" D
174 .S PSUCT3=$P($G(^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIVNM)),U,1)
175 .S PSUTOTAL=PSUTOTAL+PSUCT3
176 .D SPACE
177 .S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" "_PSUDIVNM_" Division:"_PSUTB1_PSUCT3
178 .S I=I+1
179 S ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")=PSUTOTAL ;Total of all divisions
180 Q
181 ;
182SPACE ;S ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")=PSUTOTAL ;Total of all divisions
183 ;
184 S PSUTB1=" "
185 S PSUTB2=(59-$L(PSUCT3))-$L(PSUDIVNM)-10
186 F S2=1:1:(PSUTB2-1) S PSUTB(S2)=" " D
187 .S PSUTB1=PSUTB1_PSUTB(S2) ;Tab position
188 Q
189 ;
190TAB1 ;EN Calculate tab spacing for 'Total of all Divisions' line,
191 ;and set the last lines of message into the summary global.
192 ;
193 N PSUTB3,PSUTB4,PSUTB5
194 ;
195 S PSUTB3=" "
196 S PSUTB4=" Total of all Divisions: "
197 S PSUTB5=(64-$L(PSUTB4))-$L($P(^XTMP("PSU_"_PSUJOB,"PSUTOTAL"),U,1))
198 F S3=1:1:(PSUTB5-1) S PSUTB(S3)=" " D
199 .S PSUTB3=PSUTB3_PSUTB(S3) ;Tab position
200 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" ------------" S I=I+1
201 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB4_PSUTB3_$P(^XTMP("PSU_"_PSUJOB,"PSUTOTAL"),U,1) S I=I+1
202 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="" S I=I+1
203 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="* This report includes Outpatients receiving IV orders." S I=I+1
204 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="" S I=I+1
205 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="**PLEASE NOTE: Final TOTAL may not match sum of all SUBTOTALS. A patient may" S I=I+1
206 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="have been provided pharmacy services at more than one outpatient and/or" S I=I+1
207 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="inpatient division."
208 Q
209 ;
210NODATA ;Summary report line to be sent if there is no data
211 ;
212 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY INPATIENT (IV) UNIQUE PATIENTS REPORT"
213 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",2)=" "
214 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)="No data to report"
215 D PDSUM^PSUDEM5
216 Q
Note: See TracBrowser for help on using the repository browser.