1 | ACKQDWLP ;AUG/JLTP BIR/PTD HCIOFO/BH-Print A&SP Capitation Report ; [ 03/28/96 10:45 AM ]
|
---|
2 | ;;3.0;QUASAR;**1**;Feb 11, 2000
|
---|
3 | ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
|
---|
4 | ;
|
---|
5 | ; Developed within V.3, works at Div level rather than site level -
|
---|
6 | ; - pre v.3
|
---|
7 | ;
|
---|
8 | K ^TMP("ACKQDWLP",$J)
|
---|
9 | OPTN ; Introduce option
|
---|
10 | W @IOF,!,"This option produces a four-part Capitation Report.",!,"It includes Demographic, Diagnostic and Procedure data.",!
|
---|
11 | ;
|
---|
12 | DIV ; select Div (user may select one/many/ALL)
|
---|
13 | S ACKDIV=$$DIV^ACKQUTL2(3,.ACKDIV,"IA") G:'ACKDIV EXIT
|
---|
14 | D GETDT^ACKQWL G:$D(DIRUT) EXIT D INIT^ACKQWL
|
---|
15 | ;
|
---|
16 | DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
|
---|
17 | K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
|
---|
18 | I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^ACKQDWLP",ZTDESC="QUASAR - Print A&SP Capitation Report",ZTSAVE("ACK*")="" D ^%ZTLOAD D HOME^%ZIS K ZTSK G EXIT
|
---|
19 | DQ ; Entry point when queued.
|
---|
20 | U IO
|
---|
21 | D NOW^%DTC S ACKCDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0 K ^TMP("ACKQWLD",$J)
|
---|
22 | D COMPILE,PRINT
|
---|
23 | ;
|
---|
24 | EXIT ; ALWAYS EXIT HERE
|
---|
25 | K %I,ACKBFY,ACKCDT,ACKDA,ACKEM,ACKM,ACKPG,AS,CDR,CPT,DIR,DIRUT,DTOUT
|
---|
26 | K ACKDIV,DUOUT,I,ICD,LN,T,X,XAS,Y,ZIP,^TMP("ACKQDWLP",$J)
|
---|
27 | W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
|
---|
28 | Q
|
---|
29 | ;
|
---|
30 | COMPILE ; Comp properly sorted data in ^TMP
|
---|
31 | N ACK1,ACKVDVN,ACK6,ACKREC,ACKAUD,ACKSPE
|
---|
32 | ;
|
---|
33 | S ACK1=""
|
---|
34 | F S ACK1=$O(ACKDIV(ACK1)) Q:ACK1="" D
|
---|
35 | . S ACKVDVN=$P(ACKDIV(ACK1),U,1)
|
---|
36 | . D ZIPSTAT,ICDSTAT,CPTSTAT,ECSTAT^ACKQDWLU
|
---|
37 | Q
|
---|
38 | ;
|
---|
39 | ZIPSTAT ; ZIP stats
|
---|
40 | N ACKCODE
|
---|
41 | S ACK6=0
|
---|
42 | F S ACK6=$O(^ACK(509850.7,ACKDA,5,ACKVDVN,3,ACK6)) Q:ACK6=""!(ACK6'?.N) D
|
---|
43 | . S ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,3,ACK6,0)
|
---|
44 | . S ACKAUD=$P(ACKREC,U,2,5),ACKSPE=$P(ACKREC,U,6,9)
|
---|
45 | . S ACKCODE=$P(ACKREC,U,1)
|
---|
46 | . I $TR(ACKAUD,"^","")'="" D
|
---|
47 | . . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,3,"A",ACKCODE)=ACKAUD
|
---|
48 | . . S ^TMP("ACKQDWLP",$J,"S",3,"A",ACKCODE,ACKVDVN)=ACKAUD
|
---|
49 | . I $TR(ACKSPE,"^","")'="" D
|
---|
50 | . . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,3,"S",ACKCODE)=ACKSPE
|
---|
51 | . . S ^TMP("ACKQDWLP",$J,"S",3,"S",ACKCODE,ACKVDVN)=ACKSPE
|
---|
52 | Q
|
---|
53 | ;
|
---|
54 | ICDSTAT ; ICD stats
|
---|
55 | N ACKCODE
|
---|
56 | S ACK6=0
|
---|
57 | F S ACK6=$O(^ACK(509850.7,ACKDA,5,ACKVDVN,1,ACK6)) Q:ACK6=""!(ACK6'?.N) D
|
---|
58 | . S ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,1,ACK6,0)
|
---|
59 | . S ACKAUD=$P(ACKREC,U,2,4),ACKSPE=$P(ACKREC,U,5,7)
|
---|
60 | . S ACKCODE=$P(ACKREC,U,1)
|
---|
61 | . S ACKCODE=$$GET1^DIQ(80,ACKCODE,.01)
|
---|
62 | . S ACKCODE=($S(ACKCODE?.NP:+ACKCODE,1:ACKCODE))
|
---|
63 | . I $TR(ACKAUD,"^","")'="" D
|
---|
64 | . . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,1,"A",ACKCODE)=ACKAUD
|
---|
65 | . . S ^TMP("ACKQDWLP",$J,"S",1,"A",ACKCODE,ACKVDVN)=ACKAUD
|
---|
66 | . I $TR(ACKSPE,"^","")'="" D
|
---|
67 | . . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,1,"S",ACKCODE)=ACKSPE
|
---|
68 | . . S ^TMP("ACKQDWLP",$J,"S",1,"S",ACKCODE,ACKVDVN)=ACKSPE
|
---|
69 | Q
|
---|
70 | ;
|
---|
71 | CPTSTAT ; CPT Stats
|
---|
72 | N ACKCODE
|
---|
73 | S ACK6=0
|
---|
74 | F S ACK6=$O(^ACK(509850.7,ACKDA,5,ACKVDVN,2,ACK6)) Q:ACK6=""!(ACK6'?.N) D
|
---|
75 | . S ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,2,ACK6,0)
|
---|
76 | . S ACKAUD=$P(ACKREC,U,2,4),ACKSPE=$P(ACKREC,U,5,7)
|
---|
77 | . S ACKCODE=$P(ACKREC,U,1)
|
---|
78 | . I $TR(ACKAUD,"^","")'="" D
|
---|
79 | . . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,2,"A",ACKCODE)=ACKAUD
|
---|
80 | . . S ^TMP("ACKQDWLP",$J,"S",2,"A",ACKCODE,ACKVDVN)=ACKAUD
|
---|
81 | . I $TR(ACKSPE,"^","")'="" D
|
---|
82 | . . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,2,"S",ACKCODE)=ACKSPE
|
---|
83 | . . S ^TMP("ACKQDWLP",$J,"S",2,"S",ACKCODE,ACKVDVN)=ACKSPE
|
---|
84 | Q
|
---|
85 | ;
|
---|
86 | PRINT ; Display results
|
---|
87 | N ACKDNME,ACKK1,ACKDIEN
|
---|
88 | ;
|
---|
89 | S ACKDNME=""
|
---|
90 | N ACKK1,ACKDIEN,ACKPASS
|
---|
91 | S ACKPASS=0,ACKK1=""
|
---|
92 | F S ACKK1=$O(ACKDIV(ACKK1)) Q:ACKK1="" D
|
---|
93 | . S ACKDIEN=$P(ACKDIV(ACKK1),U,1)
|
---|
94 | . I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN)) S ACKPASS=1
|
---|
95 | I 'ACKPASS D DHD,LINE W !!,"No Capitation data found for selected Divisions." D:$E(IOST)="C" PAUSE^ACKQUTL Q
|
---|
96 | ;
|
---|
97 | S ACKK1=""
|
---|
98 | F S ACKK1=$O(ACKDIV(ACKK1)) Q:ACKK1=""!($D(DIRUT)) D
|
---|
99 | . S ACKDIEN=$P(ACKDIV(ACKK1),U,1)
|
---|
100 | . S ACKDNME=$P(ACKDIV(ACKK1),U,3)
|
---|
101 | . ;
|
---|
102 | . I '$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,0)) D Q
|
---|
103 | .. D DHD,LINE
|
---|
104 | .. W !!,"No data found for this Division."
|
---|
105 | .. D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
|
---|
106 | . ;
|
---|
107 | . I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN,3)) D DHD,HD1,ZIP Q:$D(DIRUT)
|
---|
108 | . I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN,1)) D DHD,HD2,ICD Q:$D(DIRUT)
|
---|
109 | . I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN,2)) D DHD,HD3,CPT Q:$D(DIRUT)
|
---|
110 | . I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN,5)) D DHD,HD4,EC Q:$D(DIRUT)
|
---|
111 | . ;
|
---|
112 | Q:$D(DIRUT)
|
---|
113 | D SUMZIP^ACKQDWLR Q:$D(DIRUT)
|
---|
114 | D SUMICD^ACKQDWLR Q:$D(DIRUT)
|
---|
115 | D SUMCPT^ACKQDWLR Q:$D(DIRUT)
|
---|
116 | D SUMEC^ACKQDWLR Q:$D(DIRUT)
|
---|
117 | Q
|
---|
118 | ;
|
---|
119 | ZIP ; For all visits
|
---|
120 | N ACKZCT,ACKZTT,ACKZUT,ACKZCPT
|
---|
121 | S AS=""
|
---|
122 | F S AS=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,3,AS)) Q:AS=""!($D(DIRUT)) D
|
---|
123 | .S ACKZCT=0,ACKZTT=0,ACKZUT=0,ACKZCPT=0
|
---|
124 | .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD1
|
---|
125 | .S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
|
---|
126 | .W !," "_XAS,":"
|
---|
127 | .S (ZIP,T)="" F S ZIP=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,3,AS,ZIP)) Q:ZIP=""!($D(DIRUT)) D
|
---|
128 | ..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD1 W !," "_XAS,":"
|
---|
129 | ..S X=^TMP("ACKQDWLP",$J,"R",ACKDIEN,3,AS,ZIP)
|
---|
130 | ..; Print Zip data
|
---|
131 | ..W !," "_ZIP ; Write zero's instead of nulls
|
---|
132 | ..W ?25,$S($P(X,U,1):$P(X,U,1),1:"0")
|
---|
133 | ..W ?39,$S($P(X,U,2):$P(X,U,2),1:"0")
|
---|
134 | ..W ?55,$S($P(X,U,3):$P(X,U,3),1:"0")
|
---|
135 | ..W ?69,$S($P(X,U,4):$P(X,U,4),1:"0")
|
---|
136 | ..;
|
---|
137 | ..; Calculate Totals
|
---|
138 | ..S ACKZCT=ACKZCT+$P(X,U,1),ACKZTT=ACKZTT+$P(X,U,2)
|
---|
139 | ..S ACKZUT=ACKZUT+$P(X,U,3),ACKZCPT=ACKZCPT+$P(X,U,4)
|
---|
140 | ..;
|
---|
141 | .Q:$D(DIRUT)
|
---|
142 | .S $P(LN,"-",80)="" W !,LN
|
---|
143 | .W !," "_XAS," Total: ",?25,ACKZCT,?39,ACKZTT,?55,ACKZUT,?69,ACKZCPT,!
|
---|
144 | Q:$D(DIRUT)
|
---|
145 | D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
|
---|
146 | Q
|
---|
147 | ;
|
---|
148 | ICD ; ICD stats
|
---|
149 | N ACKICT,ACKITT,ACKIUT
|
---|
150 | ; D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
|
---|
151 | S AS=0 F S AS=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,1,AS)) Q:AS=""!($D(DIRUT)) D
|
---|
152 | .S ACKICT=0,ACKITT=0,ACKIUT=0
|
---|
153 | .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
|
---|
154 | .S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
|
---|
155 | .W !," "_XAS,":"
|
---|
156 | .S ICD="" F S ICD=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,1,AS,ICD)) Q:ICD=""!($D(DIRUT)) D
|
---|
157 | ..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
|
---|
158 | ..S ACKSTR=^TMP("ACKQDWLP",$J,"R",ACKDIEN,1,AS,ICD)
|
---|
159 | ..; Display data
|
---|
160 | ..W !," "_ICD
|
---|
161 | ..W ?25,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
|
---|
162 | ..W ?39,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
|
---|
163 | ..W ?55,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
|
---|
164 | ..; Calculate Totals
|
---|
165 | ..S ACKICT=ACKICT+$P(ACKSTR,U,1),ACKITT=ACKITT+$P(ACKSTR,U,2)
|
---|
166 | ..S ACKIUT=ACKIUT+$P(ACKSTR,U,3)
|
---|
167 | ..;
|
---|
168 | .Q:$D(DIRUT)
|
---|
169 | .S $P(LN,"-",80)="" W !,LN
|
---|
170 | .W !," "_XAS," Total: ",?25,ACKICT,?39,ACKITT,?55,ACKIUT,!
|
---|
171 | .Q:$D(DIRUT)
|
---|
172 | Q:$D(DIRUT)
|
---|
173 | D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
|
---|
174 | Q
|
---|
175 | ;
|
---|
176 | CPT ; CPT stats
|
---|
177 | N ACKCCT,ACKCTT,ACKCUT
|
---|
178 | ;
|
---|
179 | S AS=0 F S AS=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,2,AS)) Q:AS=""!($D(DIRUT)) D
|
---|
180 | .S ACKCCT=0,ACKCTT=0,ACKCUT=0
|
---|
181 | .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
|
---|
182 | .S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
|
---|
183 | .W !," "_XAS,":"
|
---|
184 | .S CPT="" F S CPT=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,2,AS,CPT)) Q:CPT=""!($D(DIRUT)) D
|
---|
185 | ..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
|
---|
186 | ..S ACKSTR=^TMP("ACKQDWLP",$J,"R",ACKDIEN,2,AS,CPT)
|
---|
187 | ..; Display data
|
---|
188 | ..W !," "_$$GET1^DIQ(509850.4,CPT_",",.01)
|
---|
189 | ..W ?25,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
|
---|
190 | ..W ?39,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
|
---|
191 | ..W ?55,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
|
---|
192 | ..; Calculate Totals
|
---|
193 | ..S ACKCCT=ACKCCT+$P(ACKSTR,U,1),ACKCTT=ACKCTT+$P(ACKSTR,U,2)
|
---|
194 | ..S ACKCUT=ACKCUT+$P(ACKSTR,U,3)
|
---|
195 | ..;
|
---|
196 | .Q:$D(DIRUT)
|
---|
197 | .S $P(LN,"-",80)="" W !,LN
|
---|
198 | .W !," "_XAS," Total: ",?25,ACKCCT,?39,ACKCTT,?55,ACKCUT,!
|
---|
199 | .Q:$D(DIRUT)
|
---|
200 | Q:$D(DIRUT)
|
---|
201 | D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
|
---|
202 | Q
|
---|
203 | ;
|
---|
204 | EC ; EC stats
|
---|
205 | N ACKCCT,ACKCTT,ACKCUT
|
---|
206 | ;
|
---|
207 | S AS=0 F S AS=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,5,AS)) Q:AS=""!($D(DIRUT)) D
|
---|
208 | .S ACKCCT=0,ACKCTT=0,ACKCUT=0
|
---|
209 | .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD4
|
---|
210 | .S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
|
---|
211 | .W !," "_XAS,":"
|
---|
212 | .S EC="" F S EC=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,5,AS,EC)) Q:EC=""!($D(DIRUT)) D
|
---|
213 | ..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD4
|
---|
214 | ..S ACKSTR=^TMP("ACKQDWLP",$J,"R",ACKDIEN,5,AS,EC)
|
---|
215 | ..; Display data
|
---|
216 | ..W !," "_$$GET1^DIQ(725,EC_",",1,"I")
|
---|
217 | ..W ?25,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
|
---|
218 | ..W ?39,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
|
---|
219 | ..W ?55,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
|
---|
220 | ..; Calculate Totals
|
---|
221 | ..S ACKCCT=ACKCCT+$P(ACKSTR,U,1),ACKCTT=ACKCTT+$P(ACKSTR,U,2)
|
---|
222 | ..S ACKCUT=ACKCUT+$P(ACKSTR,U,3)
|
---|
223 | ..;
|
---|
224 | .Q:$D(DIRUT)
|
---|
225 | .S $P(LN,"-",80)="" W !,LN
|
---|
226 | .W !," "_XAS," Total: ",?25,ACKCCT,?39,ACKCTT,?55,ACKCUT,!
|
---|
227 | .Q:$D(DIRUT)
|
---|
228 | Q:$D(DIRUT)
|
---|
229 | D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
|
---|
230 | Q
|
---|
231 | ;
|
---|
232 | DHD ;
|
---|
233 | N X
|
---|
234 | W:($E(IOST)="C")!(ACKPG>0) @IOF
|
---|
235 | S ACKPG=ACKPG+1
|
---|
236 | W "Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG
|
---|
237 | W ! D CNTR^ACKQUTL("Audiology & Speech Pathology")
|
---|
238 | W ! D CNTR^ACKQUTL("Capitation Report")
|
---|
239 | I ACKPASS W ! D CNTR^ACKQUTL("for DIVISION: "_ACKDNME)
|
---|
240 | W ! D CNTR^ACKQUTL($$XDAT^ACKQUTL(ACKM)) W !
|
---|
241 | Q
|
---|
242 | ;
|
---|
243 | HD1 ; Header for all visits
|
---|
244 | N X
|
---|
245 | W !,?23,"CLINIC",?36,"TELEPHONE",?53,"UNIQUE"
|
---|
246 | W !," ZIP CODE",?23,"VISITS",?37,"VISITS",?52,"PATIENTS",?68,"C&P"
|
---|
247 | D LINE Q
|
---|
248 | ;
|
---|
249 | HD2 ; Head for ICD stats
|
---|
250 | N X W !,?23,"CLINIC",?36,"TELEPHONE"
|
---|
251 | W !," ICD",?23,"VISITS",?37,"VISITS",?53,"UNIQUE" D LINE Q
|
---|
252 | ;
|
---|
253 | HD3 ; Head for CPT stats
|
---|
254 | N X W !,?23,"CLINIC",?36,"TELEPHONE"
|
---|
255 | W !," CPT",?23,"VISITS",?37,"VISITS",?53,"UNIQUE" D LINE Q
|
---|
256 | ;
|
---|
257 | HD4 ; Head for EC stats
|
---|
258 | N X W !,?23,"CLINIC",?36,"TELEPHONE"
|
---|
259 | W !," EC",?23,"VISITS",?37,"VISITS",?53,"UNIQUE" D LINE Q
|
---|
260 | ;
|
---|
261 | LINE S X="",$P(X,"-",IOM)="-" W !,X Q
|
---|
262 | ;
|
---|