source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUSUM3.m@ 851

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1PSUSUM3 ;BIR/DAM - Patient Demographics Summary for UD 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 1848
7 ; Reference to file #40.8 supported by DBIA 1576
8 ;
9EN ;EN CALLED FROM PSUUD0
10 ;Q:$D(^XTMP("PSU_"_PSUJOB,"PSUMFLAG")) ;Do not run if auto extract
11 ;
12 D PULL^PSUCP
13 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
14 ;
15 I $D(^XTMP("PSU_"_PSUJOB,"PSUNONE","UD")) D Q ;report if there is no data
16 .I $D(PSUMOD(2))&'$D(PSUMOD(1)) D
17 ..I '$D(PSUMOD(4)) D
18 ...D NODATA D
19 ....I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG1")) K ^XTMP("PSU_"_PSUJOB,"PSUNONE")
20 ....K ^XTMP("PSU_"_PSUJOB,"PSUSUMA")
21 D EN1
22 Q
23 ;
24EN1 ;Entry point to collect data
25 D DATE
26 M ^XTMP("PSU_"_PSUJOB,"PSUUD")=^XTMP(PSUUDSUB)
27 D RE
28 D UNIQUE
29 S I=9 ;Line counter for division data in summary report
30 D DIVNUM
31 D TOTAL
32 D TAB1
33 ;
34 I $D(PSUMOD(1))&$D(PSUMOD(2)) D
35 .I $D(PSUMOD(4)) D
36 ..M ^XTMP("PSU_"_PSUJOB,"PSUUDDIV")=^XTMP("PSU_"_PSUJOB,"PSUCT")
37 ..M ^XTMP("PSU_"_PSUJOB,"PSUUDSSN")=^XTMP("PSU_"_PSUJOB,"PSUIPT")
38 ..M ^XTMP("PSU_"_PSUJOB,"PSUDIVUD")=^XTMP("PSU_"_PSUJOB,"PSUDIV")
39 ;
40 I '$D(PSUMOD(1))&$D(PSUMOD(2)) D
41 .I $D(PSUMOD(4)) D
42 ..M ^XTMP("PSU_"_PSUJOB,"PSUUDDIV")=^XTMP("PSU_"_PSUJOB,"PSUCT")
43 ..M ^XTMP("PSU_"_PSUJOB,"PSUUDSSN")=^XTMP("PSU_"_PSUJOB,"PSUIPT")
44 ;
45 I $D(PSUMOD(1))&$D(PSUMOD(2)) D
46 .I '$D(PSUMOD(4)) D
47 ..M ^XTMP("PSU_"_PSUJOB,"PSUUDDIV")=^XTMP("PSU_"_PSUJOB,"PSUCT")
48 ..M ^XTMP("PSU_"_PSUJOB,"PSUUDIN")=^XTMP("PSU_"_PSUJOB,"PSUIPT")
49 ..M ^XTMP("PSU_"_PSUJOB,"PSUDIVUD")=^XTMP("PSU_"_PSUJOB,"PSUDIV")
50 ;
51 I '$D(PSUMOD(1))&'$D(PSUMOD(4)) D
52 .D PDSUM^PSUDEM5 ;Mail message
53 .K ^XTMP("PSU_"_PSUJOB,"PSUUDDIV")
54 K ^XTMP("PSU_"_PSUJOB,"PSUUD")
55 I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG1")) K ^XTMP("PSU_"_PSUJOB,"PSUSUMA")
56 K ^XTMP("PSU_"_PSUJOB,"PSUFLAG1")
57 ;K ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")
58 K ^XTMP("PSU_"_PSUJOB,"PSUCT")
59 K ^XTMP("PSU_"_PSUJOB,"PSURXCTA")
60 Q
61 ;
62RE ;Rearrange the ^XTMP("PSU_"_PSUJOB,"PSUUD","DETAIL" global so information in PATDIV
63 ;can be accessed quickly.
64 ;
65 N PSUSIT
66 S PSUSIT=PSUSNDR
67 ;D INST^PSUDEM1 S PSUSIT=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
68 ;
69 N PSUSSNA,PSUUDA
70 S PSUPN1=0,PSUSIT1=0
71 F S PSUSIT1=$O(^XTMP("PSU_"_PSUJOB,"PSUUD","DETAIL",PSUSIT1)) Q:PSUSIT1="" D
72 .F S PSUPN1=$O(^XTMP("PSU_"_PSUJOB,"PSUUD","DETAIL",PSUSIT1,PSUPN1)) Q:PSUPN1="" D
73 ..S PSUUDA=$P($G(^XTMP("PSU_"_PSUJOB,"PSUUD","DETAIL",PSUSIT1,PSUPN1)),U,4)
74 ..S PSUSSNA=$P($G(^XTMP("PSU_"_PSUJOB,"PSUUD","DETAIL",PSUSIT1,PSUPN1)),U,5) D
75 ...S PSUDFN=0
76 ...F S PSUDFN=$O(^XTMP("PSU_"_PSUJOB,"PSUTDFN",PSUDFN)) Q:PSUDFN="" D
77 ....S PSUSN=0
78 ....F S PSUSN=$O(^XTMP("PSU_"_PSUJOB,"PSUTDFN",PSUDFN,PSUSN)) Q:PSUSN="" D
79 .....I PSUSN=PSUSSNA S ^XTMP("PSU_"_PSUJOB,"PSUORSN1",PSUDFN,PSUUDA)=PSUSN
80 .....;S ^XTMP("PSU_"_PSUJOB,"PSUORSN",PSUUDA)=PSUSSNA
81 Q
82 ;
83DATE ;Convert date range of extract to external format
84 ;
85 S %H=$E($H,1,5) ;today's date
86 D YX^%DTC
87 N PSUD S PSUD=Y
88 ;
89 S Y=PSUSDT ;Start date of extract
90 D DD^%DT
91 N PSUS S PSUS=Y
92 ;
93 S Y=PSUEDT ;End date of extract
94 D DD^%DT
95 N PSUE S PSUE=Y
96 ;
97 D UDSUM
98 Q
99 ;
100UDSUM ;Summary report header to be run if UD (Inpatient) extract is run
101 ;
102 ;Report header
103 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY INPATIENT (UD) UNIQUE PATIENTS REPORT "_PSUD
104 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",2),"-",80)="" ;Separator bar
105 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)=" "_PSUS_" through "_PSUE
106 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",4),"=",80)=""
107 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",5)=" UNIQUE"
108 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",6),"-",70)=""
109 Q
110 ;
111UNIQUE ;Find number of unique patients across all divisions
112 ;
113 S PSUUDS=0
114 N PSUUDS3
115 F S PSUUDS=$O(^XTMP("PSU_"_PSUJOB,"PSUORSN1",PSUUDS)) Q:PSUUDS="" D
116 .S PSUUDS1=0
117 .S PSUUDS1=$O(^XTMP("PSU_"_PSUJOB,"PSUORSN1",PSUUDS,PSUUDS1)) Q:PSUUDS1="" D
118 ..S PSUUDS3=$P($G(^XTMP("PSU_"_PSUJOB,"PSUORSN1",PSUUDS,PSUUDS1)),U,1)
119 ..S ^XTMP("PSU_"_PSUJOB,"PSUIPT",PSUUDS3)="" ;Set up global for unique SSNs
120 .;S PSUUDS1=$P(^XTMP("PSU_"_PSUJOB,"PSUORSN",PSUUDS),U)
121 .;S ^XTMP("PSU_"_PSUJOB,"PSUIPT",PSUUDS1)="" ;Set up global for unique SSNs
122 ;
123 S B=1
124 S PSUUDS2=0
125 F S PSUUDS2=$O(^XTMP("PSU_"_PSUJOB,"PSUIPT",PSUUDS2)) Q:PSUUDS2="" D
126 .S ^XTMP("PSU_"_PSUJOB,"PSUIPT")=B,B=B+1 ;B=total count unique patients
127 .D TAB2
128 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",8),"-",70)=""
129 Q
130 ;
131TAB2 ;Tab spacing for line 7. Set line into global
132 ;
133 N PSUTB3,PSUTB4,PSUTB5
134 ;
135 S PSUTB3=" "
136 S PSUTB4="TOTAL patients across all divisions:"
137 S PSUTB5=(64-$L(PSUTB4))-$L($P($G(^XTMP("PSU_"_PSUJOB,"PSUIPT")),U,1))
138 F S3=1:1:(PSUTB5-1) S PSUTB(S3)=" " D
139 .S PSUTB3=PSUTB3_PSUTB(S3)
140 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",7)=PSUTB4_PSUTB3_$P($G(^XTMP("PSU_"_PSUJOB,"PSUIPT")),U,1)
141 Q
142 ;
143DIVNUM ;Set number of patients per division into summary message
144 ;
145 N PSUTB1,PSUTB2
146 ;
147 N PSUCT3
148 S PSUDIVA2=0
149 F S PSUDIVA2=$O(^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIVA2)) Q:PSUDIVA2="" D
150 .S PSUCT3=$P($G(^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIVA2)),U,1)
151 .D TAB
152 .S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" "_PSUDIVA2_" Division:"_PSUTB1_PSUCT3
153 .S I=I+1
154 Q
155 ;
156TAB ;Calculate tab spacing
157 ;
158 S PSUTB1=" "
159 S PSUTB2=(59-$L(PSUCT3))-$L(PSUDIVA2)-10
160 F S2=1:1:(PSUTB2-1) S PSUTB(S2)=" " D
161 .S PSUTB1=PSUTB1_PSUTB(S2) ;Tab position
162 Q
163 ;
164TOTAL ;EN Calculate Inpatient total of all divisions
165 ;
166 N PSUIPCT
167 S PSUIPTOT=0
168 S PSUTOCT1=0
169 F S PSUIPTOT=$O(^XTMP("PSU_"_PSUJOB,"PSUCT",PSUIPTOT)) Q:PSUIPTOT="" D
170 .S PSUIPCT=$P($G(^XTMP("PSU_"_PSUJOB,"PSUCT",PSUIPTOT)),U,1)
171 .S PSUTOCT1=PSUTOCT1+PSUIPCT
172 S $P(^XTMP("PSU_"_PSUJOB,"PSUTOTAL"),U,1)=PSUTOCT1
173 Q
174 ;
175TAB1 ;EN Calculate tab spacing for 'Outpatient Total of all Divisions' line.
176 ;and set the last lines of message into the summary global.
177 ;
178 N PSUTB3,PSUTB4,PSUTB5
179 ;
180 I '$G(^XTMP("PSU_"_PSUJOB,"PSUTOTAL")) D
181 .S ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")=0
182 S PSUTB3=" "
183 S PSUTB4=" Inpatient Total of all Divisions:"
184 S PSUTB5=(64-$L(PSUTB4))-$L($P($G(^XTMP("PSU_"_PSUJOB,"PSUTOTAL")),U,1))
185 F S3=1:1:(PSUTB5-1) S PSUTB(S3)=" " D
186 .S PSUTB3=PSUTB3_PSUTB(S3) ;Tab position
187 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" ----------" S I=I+1
188 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB4_PSUTB3_$P($G(^XTMP("PSU_"_PSUJOB,"PSUTOTAL")),U,1) S I=I+1
189 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="" S I=I+1
190 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="**PLEASE NOTE: Final TOTAL may not match sum of all SUBTOTALS. A patient may" S I=I+1
191 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="have been provided pharmacy services at more than one outpatient and/or" S I=I+1
192 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)="inpatient division."
193 Q
194 ;
195NODATA ;Summary report line to be sent if there is no data
196 ;
197 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY INPATIENT (UD) UNIQUE PATIENTS REPORT"
198 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",2)=" "
199 S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)="No data to report"
200 D PDSUM^PSUDEM5
201 Q
Note: See TracBrowser for help on using the repository browser.