source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQR2.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.4 KB
RevLine 
[613]1ACKQR2 ;AUG/JLTP BIR/PTD HCIOFO/AG -Statistics by Procedure ; [ 12/07/95 9:52 AM ]
2 ;;3.0;QUASAR;**1,8**;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 CPT-4 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 combo, 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^ACKQR2",ZTDESC="QUASAR - A&SP PROCEDURE STATISTICS"
26 . S ZTSAVE("ACK*")="" D ^%ZTLOAD D HOME^%ZIS K ZTSK
27 ;
28DQ ; Queued entry
29 ; Vars required :-
30 ; ACKDIV() - selected divs, ACKBD,ACKXBD - beginning date range (int,ext)
31 ; ACKED,ACKXED - end date range (int, ext)
32 ; ACKASB - A=audio,S=speech,O=other,ASO=all three
33 ; ACKSS - type of report (1=one clinician etc), ACKSTF(x) - selected prvds
34 U IO
35 D NOW^%DTC S ACKCDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0
36 K ^TMP("ACKQR2",$J),ACKT,ACKT2 S ACKT2=0
37 ; $O thru visit file using 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 ; 1 way out
43 K ACK2,ACKASB,ACKBD,ACKC,ACKCDT,ACKCL,ACKCLI,ACKCLN,ACKCLNC,ACKCPT
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 ACKCPTN,ACKVOL,ACKTXT,ACKQUIT,ZTSAVE,ZTSK,^TMP("ACKQR2",$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 isnt to be included in report
63 S ACKSORT=$$STOPSORT^ACKQRU(ACKASB,ACKVSC) Q:'ACKSORT
64 ;
65 ; Check stff member for report
66 I (ACKSS=3)!(ACKSS=6) S ACKLR=$P(ACK2,U,4) Q:ACKLR="" Q:'$D(ACKSTF(ACKLR))
67 ;
68 ; Count the proc codes for visit
69 S ACKP=0 F S ACKP=$O(^ACK(509850.6,ACKV,3,ACKP)) Q:'ACKP D
70 . S ACKQQPN=$$GET1^DIQ(509850.61,ACKP_","_ACKV_",",.07,"I","","")
71 . I ACKQQPN'="" Q ; Has a Pointer to EC code therefore created by EC
72 . S ACKCPTN=$$GET1^DIQ(509850.61,ACKP_","_ACKV_",",.01,"I","","")
73 . S ACKVOL=$$GET1^DIQ(509850.61,ACKP_","_ACKV_",",.03,"I","","")
74 . S:ACKVOL<1 ACKVOL=1
75 . S ACKQUIT=0
76 . I ACKSS'=3,ACKSS'=6 D Q:ACKQUIT
77 . . S ACKLR=$$GET1^DIQ(509850.61,ACKP_","_ACKV_",",.05,"I","","")
78 . . I ACKLR="" S ACKLR=$$LEADROLE^ACKQUTL2(ACKV)
79 . . I ACKLR="" S ACKQUIT=1
80 . . I '$D(ACKSTF(ACKLR)) S ACKQUIT=1
81 . ;
82 . I '$D(^TMP("ACKQR2",$J,"CPT",1,81,ACKCPTN_",")) D GETCPT(ACKCPTN)
83 . S ACKCPT=^TMP("ACKQR2",$J,"CPT",1,81,ACKCPTN_",",.01)
84 . I ACKCPT="" Q
85 . ; Add to cnt of procs for stff member
86 . S ACKCT=+$G(^TMP("ACKQR2",$J,1,ACKVDIV,ACKSORT,ACKCLNC,ACKLR,ACKCPT))
87 . S ^TMP("ACKQR2",$J,1,ACKVDIV,ACKSORT,ACKCLNC,ACKLR,ACKCPT)=ACKCT+ACKVOL
88 . ; Add to cnt of procs for the stp code within div
89 . S ^TMP("ACKQR2",$J,0,ACKVDIV,ACKSORT,ACKCPT)=$G(^TMP("ACKQR2",$J,0,ACKVDIV,ACKSORT,ACKCPT))+ACKVOL
90 . ; Add to cnt of procs for all divs
91 . S ^TMP("ACKQR2",$J,2,ACKSORT,ACKCPT)=$G(^TMP("ACKQR2",$J,2,ACKSORT,ACKCPT))+ACKVOL
92 . ; Add to tot cnt for the stp code, the div & grand tot
93 . S ACKT(ACKVDIV,ACKSORT)=$G(ACKT(ACKVDIV,ACKSORT))+ACKVOL
94 . S ACKT(ACKVDIV)=$G(ACKT(ACKVDIV))+ACKVOL
95 . S ACKT2(ACKSORT)=$G(ACKT2(ACKSORT))+ACKVOL,ACKT2=ACKT2+ACKVOL
96 Q
97GETCPT(ACKCPTN) ; Get Proc code data & put in ^TMP
98 N ACKTMP,ACKCPT S ACKTMP=$NA(^TMP("ACKQR2",$J,"CPT",1))
99 D GETS^DIQ(81,ACKCPTN_",",".01","",ACKTMP,"ACKMSG")
100 S ACKCPT=^TMP("ACKQR2",$J,"CPT",1,81,ACKCPTN_",",.01)
101 S ^TMP("ACKQR2",$J,"CPT",1,81,ACKCPTN_",",2)=$$PROCTXT^ACKQUTL8(ACKCPTN,"")
102 S ^TMP("ACKQR2",$J,"CPT",2,ACKCPT)=ACKCPTN
103 Q
104CPTDESC(ACKCPT) ; Get Proc desc
105 N ACKCPTN S ACKCPTN=^TMP("ACKQR2",$J,"CPT",2,ACKCPT)
106 Q ^TMP("ACKQR2",$J,"CPT",1,81,ACKCPTN_",",2)
107 ;
108PRINT ; print report 4 each div
109 S ACKVDIV=""
110 I '$D(^TMP("ACKQR2",$J,1)) D Q
111 . D HDR
112 . W !!,"No data found for report specifications.",!!
113 . D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
114 F S ACKVDIV=$O(ACKDIV(ACKVDIV)) Q:ACKVDIV=""!($D(DIRUT)) D PRINT2 Q:$D(DIRUT)
115 I '$D(DIRUT) D TOTALS
116 Q
117 ;
118PRINT2 ; print for single div
119 I '$D(^TMP("ACKQR2",$J,1,ACKVDIV)) D Q
120 . D HDR
121 . W !!,"No data found for report specifications.",!!
122 . D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
123 D HDR
124 S ACKSORT=""
125 F S ACKSORT=$O(^TMP("ACKQR2",$J,1,ACKVDIV,ACKSORT)) Q:(ACKSORT="")!($D(DIRUT)) D
126 .I $Y>(IOSL-9) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HDR
127 .W !!,"STOP CODE: ",$$STOPNM^ACKQRU(ACKSORT)
128 .S ACKCLN="" F S ACKCLN=$O(^TMP("ACKQR2",$J,1,ACKVDIV,ACKSORT,ACKCLN)) Q:ACKCLN=""!($D(DIRUT)) D
129 ..I $Y>(IOSL-7) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HDR
130 ..W !!?2,"CLINIC: ",$$GET1^DIQ(44,ACKCLN_",",.01)
131 ..S ACKSTF=""
132 ..F S ACKSTF=$O(^TMP("ACKQR2",$J,1,ACKVDIV,ACKSORT,ACKCLN,ACKSTF)) Q:ACKSTF=""!($D(DIRUT)) D
133 ...I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HDR
134 ...W !!?2,$S("1^4"[ACKSS:"CLINICIAN: ","2^5"[ACKSS:"OTHER PROVIDER: ",1:"STUDENT: ")
135 ...W $$CONVERT^ACKQUTL4(ACKSTF)
136 ...S ACKCPT=""
137 ...F S ACKCPT=$O(^TMP("ACKQR2",$J,1,ACKVDIV,ACKSORT,ACKCLN,ACKSTF,ACKCPT)) Q:(ACKCPT="")!($D(DIRUT)) D
138 ....I $Y>(IOSL-3) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HDR
139 ....W !?5,ACKCPT,?15,$$CPTDESC(ACKCPT),?55,"COUNT: "
140 ....W $J(^TMP("ACKQR2",$J,1,ACKVDIV,ACKSORT,ACKCLN,ACKSTF,ACKCPT),4)
141 Q:$D(DIRUT) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
142SUMM ;
143 Q:'$D(^TMP("ACKQR2",$J,0)) D SUMHD
144 S ACKSORT=""
145 F S ACKSORT=$O(^TMP("ACKQR2",$J,0,ACKVDIV,ACKSORT)) Q:ACKSORT=""!($D(DIRUT)) D
146 .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D SUMHD
147 .W !!,"STOP CODE: ",$$STOPNM^ACKQRU(ACKSORT)
148 .S ACKCPT=""
149 .F S ACKCPT=$O(^TMP("ACKQR2",$J,0,ACKVDIV,ACKSORT,ACKCPT)) Q:(ACKCPT="")!($D(DIRUT)) D
150 ..I $Y>(IOSL-3) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D SUMHD
151 ..W !?5,ACKCPT,?15,$$CPTDESC(ACKCPT),?55,"COUNT: "
152 ..W $J(^TMP("ACKQR2",$J,0,ACKVDIV,ACKSORT,ACKCPT),4)
153 .Q:$D(DIRUT) I $Y>(IOSL-4) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D SUMHD
154 .Q:$D(DIRUT)
155 .W !!,"Total For ",$$STOPNM^ACKQRU(ACKSORT)
156 .W ?62,$J(ACKT(ACKVDIV,ACKSORT),4)
157 Q:$D(DIRUT) I $Y>(IOSL-4) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D SUMHD
158 Q:$D(DIRUT) W !!,"Total For Division: "_$$DIVNAME(ACKVDIV),?62,$J(ACKT(ACKVDIV),4)
159 Q:$D(DIRUT) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
160 Q
161 ;
162TOTALS ; Print final page of tots 4 all divs
163 Q:'$D(^TMP("ACKQR2",$J,2))
164 Q:$D(DIRUT)
165 I $O(ACKT(""))=$O(ACKT(""),-1) Q ; Must be only one div
166 D TOTLHD S ACKTXT="DIVISIONS: "
167 S ACKVDIV="" F S ACKVDIV=$O(ACKT(ACKVDIV)) Q:ACKVDIV="" D Q:$D(DIRUT)
168 . I $Y>(IOSL-3) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
169 . W !,ACKTXT,?12,$$DIVNAME(ACKVDIV) S ACKTXT=""
170 S ACKSORT=""
171 F S ACKSORT=$O(^TMP("ACKQR2",$J,2,ACKSORT)) Q:ACKSORT=""!($D(DIRUT)) D
172 . I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
173 . W !!,"STOP CODE: ",$$STOPNM^ACKQRU(ACKSORT)
174 . S ACKCPT=""
175 . F S ACKCPT=$O(^TMP("ACKQR2",$J,2,ACKSORT,ACKCPT)) Q:(ACKCPT="")!($D(DIRUT)) D
176 . . I $Y>(IOSL-3) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
177 . . W !?5,ACKCPT,?15,$$CPTDESC(ACKCPT),?55,"COUNT: "
178 . . W $J(^TMP("ACKQR2",$J,2,ACKSORT,ACKCPT),4)
179 . I $Y>(IOSL-4) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
180 . Q:$D(DIRUT)
181 . W !!,"Total For ",$$STOPNM^ACKQRU(ACKSORT)
182 . W ?62,$J(ACKT2(ACKSORT),4)
183 Q:$D(DIRUT) I $Y>(IOSL-4) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D TOTLHD
184 Q:$D(DIRUT) W !!,"Grand Total:",?62,$J(ACKT2,4)
185 Q:$D(DIRUT) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
186 Q
187HDR ;
188 W:($E(IOST)="C")!(ACKPG>0) @IOF
189 S ACKPG=ACKPG+1
190 W "Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG,!
191 W ! D CNTR^ACKQUTL("Audiology & Speech Pathology")
192 W ! D CNTR^ACKQUTL("Procedure Statistics")
193 W ! D CNTR^ACKQUTL("for")
194 I ACKSS<4 S X=$$STAFFNM($O(ACKSTF(0))) W ! D CNTR^ACKQUTL(X)
195 I ACKSS=4 W ! D CNTR^ACKQUTL("All Clinicians")
196 I ACKSS=5 W ! D CNTR^ACKQUTL("All Other Providers")
197 I ACKSS=6 W ! D CNTR^ACKQUTL("All Students")
198 W ! D CNTR^ACKQUTL("Covering "_ACKRDR)
199 I ACKVDIV]"" W ! D CNTR^ACKQUTL("For Division: "_$$DIVNAME(ACKVDIV))
200 S X="",$P(X,"-",IOM)="-" W !,X
201 Q
202SUMHD ;
203 W:($E(IOST)="C")!(ACKPG>0) @IOF
204 S ACKPG=ACKPG+1
205 W "Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG,!
206 W ! D CNTR^ACKQUTL("Audiology & Speech Pathology")
207 W ! D CNTR^ACKQUTL("Procedure Statistics")
208 W ! D CNTR^ACKQUTL("For Division: "_$$DIVNAME(ACKVDIV))
209 W ! D CNTR^ACKQUTL("Summary")
210 S X="",$P(X,"-",IOM)="-" W !,X
211 Q
212 ;
213TOTLHD W:($E(IOST)="C")!(ACKPG>0) @IOF
214 S ACKPG=ACKPG+1
215 W "Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG,!
216 W ! D CNTR^ACKQUTL("Audiology and Speech Pathology")
217 W ! D CNTR^ACKQUTL("Procedure Statistics")
218 W ! D CNTR^ACKQUTL("Summary")
219 S X="",$P(X,"-",IOM)="-" W !,X
220 Q
221DIVNAME(ACKVDIV) ; Get div name
222 Q $$GET1^DIQ(40.8,ACKVDIV_",",.01)
223STAFFNM(ACKSTF) ; Get staff name
224 Q $$MIXC^ACKQUTL($$CONVERT^ACKQUTL4(ACKSTF))
Note: See TracBrowser for help on using the repository browser.