source: FOIAVistA/trunk/r/QUASAR-ACKQ/ACKQDWLP.m@ 1801

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1ACKQDWLP ;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)
9OPTN ; Introduce option
10 W @IOF,!,"This option produces a four-part Capitation Report.",!,"It includes Demographic, Diagnostic and Procedure data.",!
11 ;
12DIV ; 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 ;
16DEV 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
19DQ ; 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 ;
24EXIT ; 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 ;
30COMPILE ; 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 ;
39ZIPSTAT ; 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 ;
54ICDSTAT ; 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 ;
71CPTSTAT ; 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 ;
86PRINT ; 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 ;
119ZIP ; 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 ;
148ICD ; 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 ;
176CPT ; 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 ;
204EC ; 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 ;
232DHD ;
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 ;
243HD1 ; 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 ;
249HD2 ; 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 ;
253HD3 ; 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 ;
257HD4 ; 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 ;
261LINE S X="",$P(X,"-",IOM)="-" W !,X Q
262 ;
Note: See TracBrowser for help on using the repository browser.