source: FOIAVistA/trunk/r/QUASAR-ACKQ/ACKQDWLR.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: 8.5 KB
Line 
1ACKQDWLR ;HCIOFO/BH-Print A&SP Capitation Report ; [ 06/06/99 10:45 AM ]
2 ;;3.0;QUASAR;**1**;Feb 11, 2000
3 ;
4 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
5 ;
6 ;
7SUMZIP ; Display summary of ZIP data
8 Q:'$D(^TMP("ACKQDWLP",$J,"S",3))
9 ;
10 N ACKF,ACKZSCTA,ACKZSTTA,ACKZSUTA,ACKZSPTA,ACKDD,ACKZC
11 N ACKSTR,ACKZSCTS,ACKZSTTS,ACKZSUTS,ACKZSPTS,ACKTYPE
12 S (ACKZSCTA,ACKZSTTA,ACKZSUTA,ACKZSPTA,ACKZSCTS,ACKZSTTS,ACKZSUTS,ACKZSPTS)=0
13 S AS="",ACKTYPE="ZIP"
14 ; Display Heading and sub heading
15 D HEADER,ZIPHD
16 ;
17 F S AS=$O(^TMP("ACKQDWLP",$J,"S",3,AS)) Q:AS=""!($D(DIRUT)) D
18 .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ZIPHD
19 .S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
20 .W !," "_XAS,":"
21 .S (ACKZC,ACKSTR)=""
22 .F S ACKZC=$O(^TMP("ACKQDWLP",$J,"S",3,AS,ACKZC)) Q:ACKZC=""!($D(DIRUT)) D
23 ..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ZIPHD W !," "_XAS,":"
24 ..S ACKF=1,ACKDD=""
25 ..F S ACKDD=$O(^TMP("ACKQDWLP",$J,"S",3,AS,ACKZC,ACKDD)) Q:ACKDD=""!($D(DIRUT)) D
26 ...S ACKSTR=^TMP("ACKQDWLP",$J,"S",3,AS,ACKZC,ACKDD)
27 ...; Print Zip data
28 ...W !
29 ...I ACKF W " "_ACKZC S ACKF=0
30 ...W ?9,$P(ACKDIV(ACKDD),U,3)
31 ...W ?32,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
32 ...W ?45,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
33 ...W ?59,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
34 ...W ?72,$S($P(ACKSTR,U,4):$P(ACKSTR,U,4),1:"0")
35 ...;
36 ...; Calculate Totals
37 ...S @("ACKZSCT"_AS)=@("ACKZSCT"_AS)+$P(ACKSTR,U,1)
38 ...S @("ACKZSTT"_AS)=@("ACKZSTT"_AS)+$P(ACKSTR,U,2)
39 ...S @("ACKZSUT"_AS)=@("ACKZSUT"_AS)+$P(ACKSTR,U,3)
40 ...S @("ACKZSPT"_AS)=@("ACKZSPT"_AS)+$P(ACKSTR,U,4)
41 ..;
42 ..Q:$D(DIRUT)
43 .Q:$D(DIRUT)
44 .S $P(LN,"-",80)="" W !,LN
45 .W !," "_XAS," Total: ",?32,@("ACKZSCT"_AS),?45,@("ACKZSTT"_AS)
46 .W ?59,@("ACKZSUT"_AS),?72,@("ACKZSPT"_AS),!
47 ;
48 Q:$D(DIRUT)
49 ; Calculate and Display Grand Total for ZIP
50 N ACKGT1,ACKGT2,ACKGT3,ACKGT4
51 S ACKGT1=$G(ACKZSCTS)+$G(ACKZSCTA)
52 S ACKGT2=$G(ACKZSTTS)+$G(ACKZSTTA)
53 S ACKGT3=$G(ACKZSUTS)+$G(ACKZSUTA)
54 S ACKGT4=$G(ACKZSPTS)+$G(ACKZSPTA)
55 I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ZIPHD W !," "_XAS,":"
56 W !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,?72,ACKGT4,!
57 D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
58 ;
59 Q
60 ;
61SUMICD ; Display summary of ICD data
62 Q:'$D(^TMP("ACKQDWLP",$J,"S",1))
63 ;
64 N ACKF,ACKISCTA,ACKISTTA,ACKISUTA,ACKDD,ACKIC
65 N ACKSTR,ACKISCTS,ACKISTTS,ACKISUTS,ACKTYPE
66 S (ACKISCTA,ACKISTTA,ACKISUTA,ACKISCTS,ACKISTTS,ACKISUTS)=0
67 S ACKTYPE="ICD"
68 ; Display main heading and sub heading
69 D HEADER,ICDCPTHD
70 ;
71 S AS=""
72 F S AS=$O(^TMP("ACKQDWLP",$J,"S",1,AS)) Q:AS=""!($D(DIRUT)) D
73 . I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD
74 . S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
75 . W !," "_XAS,":"
76 . S (ACKIC,ACKSTR)=""
77 . F S ACKIC=$O(^TMP("ACKQDWLP",$J,"S",1,AS,ACKIC)) Q:ACKIC=""!($D(DIRUT)) D
78 .. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W !," "_XAS,":"
79 .. S ACKF=1,ACKDD=""
80 .. F S ACKDD=$O(^TMP("ACKQDWLP",$J,"S",1,AS,ACKIC,ACKDD)) Q:ACKDD=""!($D(DIRUT)) D
81 ... S ACKSTR=^TMP("ACKQDWLP",$J,"S",1,AS,ACKIC,ACKDD)
82 ...; Print ICD data
83 ... W !
84 ... I ACKF W " "_ACKIC S ACKF=0
85 ... W ?9,$P(ACKDIV(ACKDD),U,3)
86 ... W ?32,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
87 ... W ?45,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
88 ... W ?59,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
89 ...;
90 ...; Calculate Totals
91 ... S @("ACKISCT"_AS)=@("ACKISCT"_AS)+$P(ACKSTR,U,1)
92 ... S @("ACKISTT"_AS)=@("ACKISTT"_AS)+$P(ACKSTR,U,2)
93 ... S @("ACKISUT"_AS)=@("ACKISUT"_AS)+$P(ACKSTR,U,3)
94 ..;
95 .. Q:$D(DIRUT)
96 . Q:$D(DIRUT)
97 . S $P(LN,"-",80)="" W !,LN
98 . W !," "_XAS," Total: ",?32,@("ACKISCT"_AS),?45,@("ACKISTT"_AS)
99 . W ?59,@("ACKISUT"_AS),!
100 ;
101 Q:$D(DIRUT)
102 ; Calculate and Display Grand Total for ZIP
103 N ACKGT1,ACKGT2,ACKGT3
104 S ACKGT1=$G(ACKISCTS)+$G(ACKISCTA)
105 S ACKGT2=$G(ACKISTTS)+$G(ACKISTTA)
106 S ACKGT3=$G(ACKISUTS)+$G(ACKISUTA)
107 ;
108 I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W !," "_XAS,":"
109 W !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,!
110 D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
111 ;
112 Q
113 ;
114SUMCPT ; Display summary of CPT data
115 Q:'$D(^TMP("ACKQDWLP",$J,"S",2))
116 ;
117 N ACKF,ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKDD,ACKCC
118 N ACKSTR,ACKCSCTS,ACKCSTTS,ACKCSUTS,ACKTYPE
119 S (ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKCSCTS,ACKCSTTS,ACKCSUTS)=0
120 S ACKTYPE="CPT"
121 ; Display main heading and sub heading
122 D HEADER,ICDCPTHD
123 ;
124 S AS=""
125 F S AS=$O(^TMP("ACKQDWLP",$J,"S",2,AS)) Q:AS=""!($D(DIRUT)) D
126 . I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD
127 . S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
128 . W !," "_XAS,":"
129 . S (ACKCC,ACKSTR)=""
130 .;
131 . F S ACKCC=$O(^TMP("ACKQDWLP",$J,"S",2,AS,ACKCC)) Q:ACKCC=""!($D(DIRUT)) D
132 .. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W " "_XAS,":"
133 .. S ACKF=1,ACKDD=""
134 .. F S ACKDD=$O(^TMP("ACKQDWLP",$J,"S",2,AS,ACKCC,ACKDD)) Q:ACKDD=""!($D(DIRUT)) D
135 ... S ACKSTR=^TMP("ACKQDWLP",$J,"S",2,AS,ACKCC,ACKDD)
136 ...; Print Zip data
137 ... W !
138 ... I ACKF W " "_$$GET1^DIQ(509850.4,ACKCC_",",.01) S ACKF=0
139 ... W ?9,$P(ACKDIV(ACKDD),U,3)
140 ... W ?32,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
141 ... W ?45,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
142 ... W ?59,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
143 ...;
144 ...; Calculate Totals
145 ... S @("ACKCSCT"_AS)=@("ACKCSCT"_AS)+$P(ACKSTR,U,1)
146 ... S @("ACKCSTT"_AS)=@("ACKCSTT"_AS)+$P(ACKSTR,U,2)
147 ... S @("ACKCSUT"_AS)=@("ACKCSUT"_AS)+$P(ACKSTR,U,3)
148 ..;
149 .. Q:$D(DIRUT)
150 . Q:$D(DIRUT)
151 . S $P(LN,"-",80)="" W !,LN
152 . W !," "_XAS," Total: ",?32,@("ACKCSCT"_AS),?45,@("ACKCSTT"_AS)
153 . W ?59,@("ACKCSUT"_AS),!
154 ;
155 Q:$D(DIRUT)
156 ; Calculate and Display Grand Total for CPT
157 N ACKGT1,ACKGT2,ACKGT3
158 S ACKGT1=$G(ACKCSCTS)+$G(ACKCSCTA)
159 S ACKGT2=$G(ACKCSTTS)+$G(ACKCSTTA)
160 S ACKGT3=$G(ACKCSUTS)+$G(ACKCSUTA)
161 ;
162 I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W !," "_XAS,":"
163 W !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,!
164 D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
165 ;
166 Q
167 ;
168SUMEC ; Display summary of EC data
169 Q:'$D(^TMP("ACKQDWLP",$J,"S",5))
170 ;
171 N ACKF,ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKDD,ACKCC
172 N ACKSTR,ACKCSCTS,ACKCSTTS,ACKCSUTS,ACKTYPE
173 S (ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKCSCTS,ACKCSTTS,ACKCSUTS)=0
174 S ACKTYPE="EC"
175 ; Display main heading and sub heading
176 D HEADER,ICDCPTHD
177 S AS=""
178 F S AS=$O(^TMP("ACKQDWLP",$J,"S",5,AS)) Q:AS=""!($D(DIRUT)) D
179 . I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD
180 . S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
181 . W !," "_XAS,":"
182 . S (ACKCC,ACKSTR)=""
183 .;
184 . F S ACKCC=$O(^TMP("ACKQDWLP",$J,"S",5,AS,ACKCC)) Q:ACKCC=""!($D(DIRUT)) D
185 .. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W " "_XAS,":"
186 .. S ACKF=1,ACKDD=""
187 .. F S ACKDD=$O(^TMP("ACKQDWLP",$J,"S",5,AS,ACKCC,ACKDD)) Q:ACKDD=""!($D(DIRUT)) D
188 ... S ACKSTR=^TMP("ACKQDWLP",$J,"S",5,AS,ACKCC,ACKDD)
189 ...; Print EC data
190 ... W !
191 ... I ACKF W " "_$$GET1^DIQ(725,ACKCC_",",1,"I") S ACKF=0
192 ... W ?9,$P(ACKDIV(ACKDD),U,3)
193 ... W ?32,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
194 ... W ?45,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
195 ... W ?59,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
196 ...;
197 ...; Calculate Totals
198 ... S @("ACKCSCT"_AS)=@("ACKCSCT"_AS)+$P(ACKSTR,U,1)
199 ... S @("ACKCSTT"_AS)=@("ACKCSTT"_AS)+$P(ACKSTR,U,2)
200 ... S @("ACKCSUT"_AS)=@("ACKCSUT"_AS)+$P(ACKSTR,U,3)
201 ..;
202 .. Q:$D(DIRUT)
203 . Q:$D(DIRUT)
204 . S $P(LN,"-",80)="" W !,LN
205 . W !," "_XAS," Total: ",?32,@("ACKCSCT"_AS),?45,@("ACKCSTT"_AS)
206 . W ?59,@("ACKCSUT"_AS),!
207 ;
208 Q:$D(DIRUT)
209 ; Calculate and Display Grand Total for EC
210 N ACKGT1,ACKGT2,ACKGT3
211 S ACKGT1=$G(ACKCSCTS)+$G(ACKCSCTA)
212 S ACKGT2=$G(ACKCSTTS)+$G(ACKCSTTA)
213 S ACKGT3=$G(ACKCSUTS)+$G(ACKCSUTA)
214 ;
215 I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W !," "_XAS,":"
216 W !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,!
217 ;
218 ; D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
219 Q
220 ;
221HEADER ; Display heading of summary report section
222 N X
223 S ACKPG=ACKPG+1 W @IOF,"Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG
224 F X="Audiology & Speech Pathology","Capitation Report Summary Report by "_ACKTYPE_" Code",$$XDAT^ACKQUTL(ACKM) W ! D CNTR^ACKQUTL(X)
225 W !
226 Q
227 ;
228ZIPHD ; Display sub heading for ZIP code
229 N X
230 W !," "_ACKTYPE,?9,"DIVISION",?30,"CLINIC",?43,"TELEPHONE",?58,"UNIQUE"
231 W !," EXAMS",?30,"VISITS",?44,"VISITS",?57,"PATIENTS",?71,"C&P"
232 D LINE
233 Q
234 ;
235ICDCPTHD ; Display sub heading for ICD/CPT code
236 N X
237 W !," "_ACKTYPE,?9,"DIVISION",?30,"CLINIC",?43,"TELEPHONE",?58,"UNIQUE"
238 W !," EXAMS",?30,"VISITS",?44,"VISITS",?57,"PATIENTS"
239 D LINE
240 Q
241 ;
242 ;
243LINE ; Write line if dashes
244 S X="",$P(X,"-",IOM)="-" W !,X
245 Q
246 ;
Note: See TracBrowser for help on using the repository browser.