source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQR5.m@ 1800

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

initial load of WorldVistAEHR
File size: 9.3 KB
RevLine 
[613]1ACKQR5 ;HCIOFO/BH -Statistics by EC Code ; [ 10/10/00 9:52 AM ]
2 ;;3.0;QUASAR;**1**;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;
5OPTN W @IOF,!,"This option produces a report listing clinic visits for a date range"
6 W !,"sorted by Event Capture procedure codes.",!
7 ;
8 S ACKDIV=$$DIV^ACKQUTL2(3,.ACKDIV,"AI") G:+ACKDIV=0 EXIT
9 ; Date's
10 D DTRANGE^ACKQRU G:$D(DIRUT) EXIT
11 S ACKRDR="Visits from "_ACKXBD_" to "_ACKXED
12 ;
13 ; Type of report: Returns-
14 ; ACKASB="A","S","O" or a combination, ACKSS=1-6 (1=one clinician etc)
15 ; ACKSTF(x) selected staff members
16 D PARAMS^ACKQRU G:$D(DIRUT) EXIT
17 ;
18DEV W !!,"The right margin for this report is 80."
19 W !,"You can queue it to run at a later time.",!
20 K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS
21 I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
22 ; Queue selected
23 I $D(IO("Q")) D G EXIT
24 . K IO("Q")
25 . S ZTRTN="DQ^ACKQR5",ZTDESC="QUASAR - A&SP EC PROCEDURE STATISTICS"
26 . S ZTSAVE("ACK*")="" D ^%ZTLOAD D HOME^%ZIS K ZTSK
27 ;
28DQ ; Queued entry point
29 ; Vars required are:-
30 ; ACKDIV() - selected divs, ACKBD,ACKXBD - beginning of date range (internal,external)
31 ; ACKED,ACKXED - end of date range (internal, external)
32 ; ACKASB - A=audio,S=speech,O=other,ASO=all three
33 ; ACKSS - type of report (1=one clinician etc), ACKSTF(x) - selected providers
34 U IO
35 D NOW^%DTC S ACKCDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0
36 K ^TMP("ACKQR5",$J),ACKT,ACKT2 S ACKT2=0
37 ; $O thru visit file using the date index
38 F ACKD=ACKBD:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKED) D
39 . S ACKV=0 F S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV D STORE
40 D PRINT
41 ;
42EXIT ; Only way out
43 K ACK2,ACKASB,ACKBD,ACKC,ACKCDT,ACKCL,ACKCLI,ACKCLN,ACKCLNC,ACKEC
44 K ACKSORT,ACKD,ACKED,ACKHDR2,ACKI,ACKLINE,ACKLR,ACKOOP,ACKP,ACKPC
45 K ACKPCP,ACKPG,ACKRDR,ACKSS,ACKSTAFF,ACKSTF,ACKT,ACKV,ACKVSC,ACKXBD
46 K ACKXED,ACKT2,ACKCT,ACKVDIV,ACKOK,ACKHDR,ACKDIV,ACKHDR5,ACKSORT
47 K ACKECN,ACKVOL,ACKTXT,ACKQUIT,ZTSAVE,ZTSK,^TMP("ACKQR5",$J)
48 K %DT,%I,%ZIS,%T,DIRUT,DTOUT,DUOUT,I,JJ,SS,X,Y,ZTDESC,ZTIO,ZTRTN
49 W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
50 Q
51STORE ;
52 S ACKHDR=^ACK(509850.6,ACKV,0),ACKHDR5=^ACK(509850.6,ACKV,5)
53 ; Get div & make sure it was selected
54 S ACKVDIV=$P(ACKHDR5,U,1)
55 I '$D(ACKDIV(ACKVDIV)) Q
56 ;
57 S ACKCLNC=+$P(ACKHDR,U,6) ; clinic IEN
58 Q:'ACKCLNC
59 S ACK2=$G(^ACK(509850.6,ACKV,2))
60 S ACKVSC=$P(ACK2,U) ; clinic stp code
61 ; Determine sort order for visit stp code (will return zero if
62 ; the visit is not to be included in the report)
63 S ACKSORT=$$STOPSORT^ACKQRU(ACKASB,ACKVSC) Q:'ACKSORT
64 ;
65 ; Check staff member selected for report
66 I (ACKSS=3)!(ACKSS=6) S ACKLR=$P(ACK2,U,4) Q:ACKLR="" Q:'$D(ACKSTF(ACKLR))
67 ;
68 ; Count the EC proc codes for visit
69 S ACKP=0 F S ACKP=$O(^ACK(509850.6,ACKV,7,ACKP)) Q:'ACKP D
70 . S ACKECN=$$GET1^DIQ(509850.615,ACKP_","_ACKV_",",.01,"I","","")
71 . S ACKVOL=$$GET1^DIQ(509850.615,ACKP_","_ACKV_",",.03,"I","","")
72 . S:ACKVOL<1 ACKVOL=1
73 . S ACKQUIT=0
74 . I ACKSS'=3,ACKSS'=6 D Q:ACKQUIT
75 . . S ACKLR=$$GET1^DIQ(509850.615,ACKP_","_ACKV_",",.05,"I","","")
76 . . I ACKLR="" S ACKLR=$$LEADROLE^ACKQUTL2(ACKV)
77 . . I ACKLR="" S ACKQUIT=1
78 . . I '$D(ACKSTF(ACKLR)) S ACKQUIT=1
79 . ;
80 . I '$D(^TMP("ACKQR5",$J,"EC",1,725,ACKECN_",")) D GETEC(ACKECN)
81 . S ACKEC=^TMP("ACKQR5",$J,"EC",1,725,ACKECN_",",1)
82 . I ACKEC="" Q
83 . ; Add to cnt of procs for stff member
84 . S ACKCT=+$G(^TMP("ACKQR5",$J,1,ACKVDIV,ACKSORT,ACKCLNC,ACKLR,ACKEC))
85 . S ^TMP("ACKQR5",$J,1,ACKVDIV,ACKSORT,ACKCLNC,ACKLR,ACKEC)=ACKCT+ACKVOL
86 . ; Add to cnt of EC procs for the stp code within div
87 . S ^TMP("ACKQR5",$J,0,ACKVDIV,ACKSORT,ACKEC)=$G(^TMP("ACKQR5",$J,0,ACKVDIV,ACKSORT,ACKEC))+ACKVOL
88 . ; Add to cnt of ec procs for all divs
89 . S ^TMP("ACKQR5",$J,2,ACKSORT,ACKEC)=$G(^TMP("ACKQR5",$J,2,ACKSORT,ACKEC))+ACKVOL
90 . ; Add to total cnt for the stp code, the div & grand total
91 . S ACKT(ACKVDIV,ACKSORT)=$G(ACKT(ACKVDIV,ACKSORT))+ACKVOL
92 . S ACKT(ACKVDIV)=$G(ACKT(ACKVDIV))+ACKVOL
93 . S ACKT2(ACKSORT)=$G(ACKT2(ACKSORT))+ACKVOL,ACKT2=ACKT2+ACKVOL
94 Q
95GETEC(ACKECN) ; Get EC Proc code data and put in ^TMP
96 N ACKTMP,ACKEC S ACKTMP=$NA(^TMP("ACKQR5",$J,"EC",1))
97 D GETS^DIQ(725,ACKECN_",",".01;1","",ACKTMP,"ACKMSG")
98 S ACKEC=^TMP("ACKQR5",$J,"EC",1,725,ACKECN_",",1)
99 S ^TMP("ACKQR5",$J,"EC",2,ACKEC)=ACKECN
100 Q
101ECDESC(ACKEC) ; Get ec Proc desc (short name)
102 N ACKECN S ACKECN=^TMP("ACKQR5",$J,"EC",2,ACKEC)
103 Q ^TMP("ACKQR5",$J,"EC",1,725,ACKECN_",",.01)
104 ;
105PRINT ; print report for each div
106 S ACKVDIV=""
107 I '$D(^TMP("ACKQR5",$J,1)) D Q
108 . D HDR
109 . W !!,"No data found for report specifications.",!!
110 . D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
111 F S ACKVDIV=$O(ACKDIV(ACKVDIV)) Q:ACKVDIV=""!($D(DIRUT)) D PRINT2 Q:$D(DIRUT)
112 I '$D(DIRUT) D TOTALS
113 Q
114 ;
115PRINT2 ; print for a single div
116 I '$D(^TMP("ACKQR5",$J,1,ACKVDIV)) D Q
117 . D HDR
118 . W !!,"No data found for report specifications.",!!
119 . D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
120 D HDR
121 S ACKSORT=""
122 F S ACKSORT=$O(^TMP("ACKQR5",$J,1,ACKVDIV,ACKSORT)) Q:(ACKSORT="")!($D(DIRUT)) D
123 .I $Y>(IOSL-9) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HDR
124 .W !!,"STOP CODE: ",$$STOPNM^ACKQRU(ACKSORT)
125 .S ACKCLN="" F S ACKCLN=$O(^TMP("ACKQR5",$J,1,ACKVDIV,ACKSORT,ACKCLN)) Q:ACKCLN=""!($D(DIRUT)) D
126 ..I $Y>(IOSL-7) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HDR
127 ..W !!?2,"CLINIC: ",$$GET1^DIQ(44,ACKCLN_",",.01)
128 ..S ACKSTF=""
129 ..F S ACKSTF=$O(^TMP("ACKQR5",$J,1,ACKVDIV,ACKSORT,ACKCLN,ACKSTF)) Q:ACKSTF=""!($D(DIRUT)) D
130 ...I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HDR
131 ...W !!?2,$S("1^4"[ACKSS:"CLINICIAN: ","2^5"[ACKSS:"OTHER PROVIDER: ",1:"STUDENT: ")
132 ...W $$CONVERT^ACKQUTL4(ACKSTF)
133 ...S ACKEC=""
134 ...F S ACKEC=$O(^TMP("ACKQR5",$J,1,ACKVDIV,ACKSORT,ACKCLN,ACKSTF,ACKEC)) Q:(ACKEC="")!($D(DIRUT)) D
135 ....I $Y>(IOSL-3) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HDR
136 ....W !?5,ACKEC,?15,$$ECDESC(ACKEC),?55,"COUNT: "
137 ....W $J(^TMP("ACKQR5",$J,1,ACKVDIV,ACKSORT,ACKCLN,ACKSTF,ACKEC),4)
138 Q:$D(DIRUT) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
139SUMM ;
140 Q:'$D(^TMP("ACKQR5",$J,0)) D SUMHD
141 S ACKSORT=""
142 F S ACKSORT=$O(^TMP("ACKQR5",$J,0,ACKVDIV,ACKSORT)) Q:ACKSORT=""!($D(DIRUT)) D
143 .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D SUMHD
144 .W !!,"STOP CODE: ",$$STOPNM^ACKQRU(ACKSORT)
145 .S ACKEC=""
146 .F S ACKEC=$O(^TMP("ACKQR5",$J,0,ACKVDIV,ACKSORT,ACKEC)) Q:(ACKEC="")!($D(DIRUT)) D
147 ..I $Y>(IOSL-3) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D SUMHD
148 ..W !?5,ACKEC,?15,$$ECDESC(ACKEC),?55,"COUNT: "
149 ..W $J(^TMP("ACKQR5",$J,0,ACKVDIV,ACKSORT,ACKEC),4)
150 .Q:$D(DIRUT) I $Y>(IOSL-4) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D SUMHD
151 .Q:$D(DIRUT)
152 .W !!,"Total For ",$$STOPNM^ACKQRU(ACKSORT)
153 .W ?62,$J(ACKT(ACKVDIV,ACKSORT),4)
154 Q:$D(DIRUT) I $Y>(IOSL-4) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D SUMHD
155 Q:$D(DIRUT) W !!,"Total For Division: "_$$DIVNAME(ACKVDIV),?62,$J(ACKT(ACKVDIV),4)
156 Q:$D(DIRUT) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
157 Q
158 ;
159TOTALS ; Print final page of totals for all divs
160 Q:'$D(^TMP("ACKQR5",$J,2))
161 Q:$D(DIRUT)
162 I $O(ACKT(""))=$O(ACKT(""),-1) Q ; Must be only one div
163 D TOTLHD S ACKTXT="DIVISIONS: "
164 S ACKVDIV="" F S ACKVDIV=$O(ACKT(ACKVDIV)) Q:ACKVDIV="" D Q:$D(DIRUT)
165 . I $Y>(IOSL-3) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
166 . W !,ACKTXT,?12,$$DIVNAME(ACKVDIV) S ACKTXT=""
167 S ACKSORT=""
168 F S ACKSORT=$O(^TMP("ACKQR5",$J,2,ACKSORT)) Q:ACKSORT=""!($D(DIRUT)) D
169 . I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
170 . W !!,"STOP CODE: ",$$STOPNM^ACKQRU(ACKSORT)
171 . S ACKEC=""
172 . F S ACKEC=$O(^TMP("ACKQR5",$J,2,ACKSORT,ACKEC)) Q:(ACKEC="")!($D(DIRUT)) D
173 . . I $Y>(IOSL-3) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
174 . . W !?5,ACKEC,?15,$$ECDESC(ACKEC),?55,"COUNT: "
175 . . W $J(^TMP("ACKQR5",$J,2,ACKSORT,ACKEC),4)
176 . I $Y>(IOSL-4) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
177 . Q:$D(DIRUT)
178 . W !!,"Total For ",$$STOPNM^ACKQRU(ACKSORT)
179 . W ?62,$J(ACKT2(ACKSORT),4)
180 Q:$D(DIRUT) I $Y>(IOSL-4) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
181 Q:$D(DIRUT) W !!,"Grand Total:",?62,$J(ACKT2,4)
182 Q:$D(DIRUT) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
183 Q
184HDR ;
185 W:($E(IOST)="C")!(ACKPG>0) @IOF
186 S ACKPG=ACKPG+1
187 W "Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG,!
188 W ! D CNTR^ACKQUTL("Audiology & Speech Pathology")
189 W ! D CNTR^ACKQUTL("EC Procedure Statistics")
190 W ! D CNTR^ACKQUTL("for")
191 I ACKSS<4 S X=$$STAFFNM($O(ACKSTF(0))) W ! D CNTR^ACKQUTL(X)
192 I ACKSS=4 W ! D CNTR^ACKQUTL("All Clinicians")
193 I ACKSS=5 W ! D CNTR^ACKQUTL("All Other Providers")
194 I ACKSS=6 W ! D CNTR^ACKQUTL("All Students")
195 W ! D CNTR^ACKQUTL("Covering "_ACKRDR)
196 I ACKVDIV]"" W ! D CNTR^ACKQUTL("For Division: "_$$DIVNAME(ACKVDIV))
197 S X="",$P(X,"-",IOM)="-" W !,X
198 Q
199SUMHD ;
200 W:($E(IOST)="C")!(ACKPG>0) @IOF
201 S ACKPG=ACKPG+1
202 W "Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG,!
203 W ! D CNTR^ACKQUTL("Audiology & Speech Pathology")
204 W ! D CNTR^ACKQUTL("EC Procedure Statistics")
205 W ! D CNTR^ACKQUTL("For Division: "_$$DIVNAME(ACKVDIV))
206 W ! D CNTR^ACKQUTL("Summary")
207 S X="",$P(X,"-",IOM)="-" W !,X
208 Q
209TOTLHD ;
210 W:($E(IOST)="C")!(ACKPG>0) @IOF
211 S ACKPG=ACKPG+1
212 W "Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG,!
213 W ! D CNTR^ACKQUTL("Audiology and Speech Pathology")
214 W ! D CNTR^ACKQUTL("EC Procedure Statistics")
215 W ! D CNTR^ACKQUTL("Summary")
216 S X="",$P(X,"-",IOM)="-" W !,X
217 Q
218 ;
219DIVNAME(ACKVDIV) ; Get div name
220 Q $$GET1^DIQ(40.8,ACKVDIV_",",.01)
221 ;
222STAFFNM(ACKSTF) ; Get staff name
223 Q $$MIXC^ACKQUTL($$CONVERT^ACKQUTL4(ACKSTF))
Note: See TracBrowser for help on using the repository browser.