source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECRDSSU.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 6.8 KB
Line 
1ECRDSSU ;ALB/ESD - DSS Unit Workload Summary Report ; 5 Aug 97
2 ;;2.0; EVENT CAPTURE ;**5,8,10,14,18,47,63,72**;8 May 96
3 ;
4EN ;- Get location(s), DSS Unit(s), start & end dates, device
5 ;
6 N ECLOC,ECDSSU,ECSTDT,ECENDDT
7 I '$$ASKLOC^ECRUTL G ENQ
8 I '$$ASKDSS^ECRUTL G ENQ
9 I '$$STDT^ECRUTL G ENQ
10 I '$$ENDDT^ECRUTL(ECSTDT) G ENQ
11 I $$ASKDEV D STRPT^ECRDSSU
12ENQ Q
13 ;
14 ;
15STRPT ;- Main entry point
16 ;
17 N ECCRT,ECDSSNM,ECDSSTOT,ECLOCNM,ECQUIT,ECPAGE
18 S (ECDSSTOT,ECPAGE,ECQUIT)=0,(ECDSSNM,ECLOCNM)=""
19 ; Determine if device is CRT
20 S ECCRT=$S($E(IOST,1,2)="C-":1,1:0)
21 U IO
22 D GETREC
23 D LOOP
24 I ECQUIT G STRPTQ
25 D PRTCAT
26 I ECQUIT G STRPTQ
27 D DSSCHG
28 I ECQUIT G STRPTQ
29 I $D(ECGUI) G STRPTQ
30 I $D(ZTQUEUED) S ZTREQ="@"
31 D ^%ZISC
32STRPTQ K ^TMP("ECRPT")
33 Q
34 ;
35 ;
36GETREC ;- Loop thru "ADT" x-ref of EC Patient file (#721)
37 ;
38 N ECD,ECDFN,ECIEN,ECL,ECNT,I,J,ECREC,ECST
39 S ECNT=0
40 F I=0:0 S I=$O(ECLOC(I)) Q:'I S ECL=+$P(ECLOC(I),U) D
41 . S ECDFN=0
42 . F S ECDFN=+$O(^ECH("ADT",ECL,ECDFN)) Q:'ECDFN F J=0:0 S J=$O(ECDSSU(J)) Q:'J S ECD=+$P(ECDSSU(J),U) D
43 .. S ECIEN=0
44 .. S ECST=ECSTDT
45 .. F S ECST=+$O(^ECH("ADT",ECL,ECDFN,ECD,ECST)) Q:'ECST!(ECST>ECENDDT) F S ECIEN=+$O(^ECH("ADT",ECL,ECDFN,ECD,ECST,ECIEN)) Q:'ECIEN D
46 ... S ECREC=$G(^ECH(ECIEN,0))
47 ... I ECD=+$P(ECREC,"^",7) D CRETMP
48 Q
49 ;
50 ;
51CRETMP ;- Create ^TMP("ECRPT" array w/format:
52 ; ^TMP("ECRPT",$J,location,DSS Unit,category,count)=procedure^volume^
53 ; CPT modifiers
54 ;
55 N ECTC,ECTP,ECMOD,ECMODS,ECMODF,SEQ
56 S ECTC=$S(+$P(ECREC,"^",8)=0:-1,1:+$P(ECREC,"^",8)),ECTP=$P($G(ECREC),"^",9)
57 S ECNT=ECNT+1,ECTP=$P(ECTP,";")_";"_$E($P(ECTP,";",2),1)
58 ;ALB/JAM - Get Procedure CPT modifiers
59 S ECMODS="" I $O(^ECH(ECIEN,"MOD",0))'="" D
60 . K ECMOD S ECMODF=$$MOD^ECUTL(ECIEN,"I",.ECMOD) I 'ECMODF Q
61 . S SEQ="" F S SEQ=$O(ECMOD(SEQ)) Q:SEQ="" D
62 . . S ECMODS=ECMODS_$S(ECMODS="":"",1:";")_SEQ
63 S ^TMP("ECRPT",$J,+$P(ECREC,"^",4),+$P(ECREC,"^",7),ECTC,ECNT)=ECTP_"^"_+$P(ECREC,"^",10)_"^"_ECMODS
64 Q
65 ;
66LOOP ;- Loop through data
67 ;
68 N ECCAT,ECNT,ECOCAT,ECDSS,ECLOCAT,ECPR,ECVOL,ECMOD
69 S (ECNT,ECDSS,ECLOCAT)=0,(ECCAT,ECOCAT)=""
70 I '$D(^TMP("ECRPT",$J)) G LOOPQ
71 F S ECLOCAT=$O(^TMP("ECRPT",$J,ECLOCAT)) Q:'ECLOCAT D
72 . F S ECDSS=$O(^TMP("ECRPT",$J,ECLOCAT,ECDSS)) Q:'ECDSS D
73 .. Q:ECQUIT
74 .. D PRTCAT Q:ECQUIT
75 .. D DSSCHG Q:ECQUIT
76 .. S ECOCAT=0
77 .. D HDR
78 .. D LOCNAM,DSSUNAM
79 .. W !!,"Location: ",$G(ECLOCNM),!,"DSS Unit: ",$G(ECDSSNM)
80 .. F S ECCAT=$O(^TMP("ECRPT",$J,ECLOCAT,ECDSS,ECCAT)) Q:ECCAT="" D
81 ... D CATCHG
82 ... Q:ECQUIT
83 ... F S ECNT=$O(^TMP("ECRPT",$J,ECLOCAT,ECDSS,ECCAT,ECNT)) Q:'ECNT D
84 .... S (ECPR,ECVOL)=0
85 .... S ECPR=$P($G(^TMP("ECRPT",$J,ECLOCAT,ECDSS,ECCAT,ECNT)),"^")
86 .... S ECVOL=$P($G(^TMP("ECRPT",$J,ECLOCAT,ECDSS,ECCAT,ECNT)),"^",2)
87 .... S ECMOD=$P($G(^TMP("ECRPT",$J,ECLOCAT,ECDSS,ECCAT,ECNT)),"^",3)
88 .... I '$D(ECTMP(ECLOCAT,ECDSS,ECCAT,ECPR)) S ECTMP(ECLOCAT,ECDSS,ECCAT,ECPR)=ECVOL D:ECMOD'="" SETMOD Q
89 .... S ECTMP(ECLOCAT,ECDSS,ECCAT,ECPR)=ECTMP(ECLOCAT,ECDSS,ECCAT,ECPR)+ECVOL D:ECMOD'="" SETMOD
90LOOPQ Q
91SETMOD ;ALB/JAM - Set CPT modifiers in ECTMP array
92 N MOD,I
93 F I=1:1 S MOD=$P(ECMOD,";",I) Q:MOD="" D
94 . S ECTMP(ECLOCAT,ECDSS,ECCAT,ECPR,MOD)=$G(ECTMP(ECLOCAT,ECDSS,ECCAT,ECPR,MOD))+ECVOL
95 Q
96 ;
97CATCHG ;- Category change
98 ;
99 I ECCAT=""&(ECOCAT="") G CATCHGQ
100 I ECOCAT="" S ECOCAT=ECCAT G CATCHGQ
101 I $G(ECOCAT)'=$G(ECCAT) D
102 . D PRTCAT
103 . S ECOCAT=ECCAT
104CATCHGQ Q
105 ;
106PRTCAT ;- Print category
107 ;
108 Q:'$D(ECTMP)
109 N ECC,ECCATOT,ECDSS,ECFLG,ECLOC,ECPR,ECPRN,ECSYI,ECSYN,ECCNAM,ECPNAM
110 N ECCPT,ECPI
111 S (ECCATOT,ECDSS,ECFLG,ECLOC)=0,(ECC,ECCNAM,ECPR)=""
112 F S ECLOC=$O(ECTMP(ECLOC)) Q:'ECLOC F S ECDSS=$O(ECTMP(ECLOC,ECDSS)) Q:'ECDSS F S ECC=$O(ECTMP(ECLOC,ECDSS,ECC)) Q:ECC="" F S ECPR=$O(ECTMP(ECLOC,ECDSS,ECC,ECPR)) Q:ECPR="" D I ECQUIT Q
113 . S ECCNAM=$S($P($G(^EC(726,$S(ECC<1:0,1:+ECC),0)),"^")'="":$P($G(^EC(726,$S(ECC<1:0,1:+ECC),0)),"^"),1:"None")
114 . S ECPRN=$S($P(ECPR,";",2)="E":ECPR_"C(725,",1:ECPR_"CPT(")
115 . S ECSYI=+$O(^ECJ("AP",ECLOC,ECDSS,$S(ECC<1:0,1:+ECC),ECPRN,0)),ECSYN=$P($G(^ECJ(ECSYI,"PRO")),"^",2)
116 . S ECPI=""
117 . S ECCPT=$S($P(ECPR,";",2)="I":+ECPR,1:$P($G(^EC(725,+ECPR,0)),"^",5))
118 . I ECCPT'="" S ECPI=$$CPT^ICPTCOD(ECCPT,$P(ECENDDT,".")),ECCPT=$P(ECPI,"^",2)
119 . S ECPNAM=$S($P(ECPR,";",2)="E":$G(^EC(725,+$P(ECPR,";"),0)),$P(ECPR,";",2)="I":$P(ECPI,"^",3),1:"") S:$P(ECPR,";",2)="E" ECPNAM=$P(ECPNAM,"^",2)_" "_$P(ECPNAM,"^")
120 . Q:ECQUIT
121 . I $Y>(IOSL-8) D PAUSE Q:ECQUIT D HDR
122 . W:'ECFLG !!?1,"Category:",!?2,ECCNAM S ECFLG=1
123 . W !?3,ECCPT,?9,$E(ECPNAM,1,35),?46,$S(ECSYN]"":$E(ECSYN,1,21),1:""),?69,$J($P($G(ECTMP(ECLOC,ECDSS,ECC,ECPR)),"^"),6)
124 . S ECCATOT=ECCATOT+$P($G(ECTMP(ECLOC,ECDSS,ECC,ECPR)),"^")
125 . I $O(ECTMP(ECLOC,ECDSS,ECC,ECPR,""))'="" D PRTMOD I ECQUIT Q
126 G:ECQUIT PRTCATQ
127 I $Y>(IOSL-8) D PAUSE G:ECQUIT PRTCATQ D HDR
128 W !?69,"------"
129 W !?6,"Total Procedures for ",ECCNAM,?69,$J(ECCATOT,6),!
130 S ECDSSTOT=ECDSSTOT+ECCATOT
131PRTCATQ K ECTMP
132 Q
133 ;
134PRTMOD ;ALB/JAM - Print CPT modifiers
135 N MOD,IEN,MODESC,MODI S IEN=""
136 F S IEN=$O(ECTMP(ECLOC,ECDSS,ECC,ECPR,IEN)) Q:IEN="" D
137 . I $Y>(IOSL-5) D PAUSE Q:ECQUIT D HDR
138 . S MODI=$$MOD^ICPTMOD(IEN,"I",$P(ECENDDT,"."))
139 . S MOD=$P(MODI,"^",2) I MOD="" Q
140 . S MODESC=$P(MODI,"^",3) I MODESC="" S MODESC="Unknown"
141 . W !?7,"- ",MOD," ",$E(MODESC,1,40)," ("
142 . W ECTMP(ECLOC,ECDSS,ECC,ECPR,IEN),")"
143 Q
144 ;
145DSSCHG ;- DSS Unit change
146 ;
147 Q:'$G(ECDSSTOT)
148 I ECDSSTOT>0 D
149 . I $Y>(IOSL-8) D PAUSE Q:ECQUIT D HDR
150 . W !!?69,"======"
151 . W !?6,"Total Procedures for ",$G(ECDSSNM),?69,$J(ECDSSTOT,6)
152 . S ECDSSTOT=0,(ECLOCNM,ECDSSNM)=""
153 . D PAUSE
154 Q
155 ;
156HDR ;- Report header
157 ;
158 I ECCRT!(ECPAGE) W @IOF
159 S ECPAGE=ECPAGE+1
160 W !,?((IOM-32)\2),"DSS UNIT WORKLOAD SUMMARY REPORT"
161 W !,?((IOM-40)\2),"Date Range: "_$$FMTE^XLFDT($P((ECSTDT+.0001),"."))_" to "_$$FMTE^XLFDT($P(ECENDDT,"."))
162 W !!,"Run Date: "_$$FMTE^XLFDT($$NOW^XLFDT)
163 W ?65," Page: ",ECPAGE
164 W !!?3,"CPT Code",?13,"Description",?46,"Synonym",?69,"Volume"
165 W !?7,"CPT Modifier (volume of modifiers use)"
166 W !,$TR($J("",79)," ","-")
167 Q
168 ;
169 ;
170LOCNAM ;- Get location name
171 ;
172 N I
173 F I=0:0 S I=$O(ECLOC(I)) Q:'I I $P($G(ECLOC(I)),"^")=ECLOCAT S ECLOCNM=$P(ECLOC(I),"^",2)
174 Q
175 ;
176 ;
177DSSUNAM ;- Get DSS Unit name
178 ;
179 N I
180 F I=0:0 S I=$O(ECDSSU(I)) Q:'I I $P($G(ECDSSU(I)),"^")=ECDSS S ECDSSNM=$P(ECDSSU(I),"^",2)
181 Q
182 ;
183 ;
184PAUSE ;- Pause for screen output
185 Q:'ECCRT
186 N DIR,DIRUT,DUOUT
187 I IOSL<30 F W ! Q:$Y>(IOSL-4)
188 W ! S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S ECQUIT=1
189 Q
190 ;
191 ;
192ASKDEV() ;- Ask device for printing or queuing report
193 ; Input: None
194 ;
195 ; Output: 1 if report is printed
196 ; 0 if report is queued (or exited out)
197 ;
198 N ECX,ZTDESC,ZTRTN,ZTSAVE
199 S ECX=1
200 K %ZIS S %ZIS="QMP"
201 D ^%ZIS
202 S:POP ECX=0
203 I ECX&($D(IO("Q"))) D
204 . S ZTRTN="STRPT^ECRDSSU",ZTDESC="DSS UNIT WORKLOAD SUMMARY REPORT"
205 . S (ZTSAVE("ECLOC("),ZTSAVE("ECDSSU("),ZTSAVE("ECSTDT"),ZTSAVE("ECENDDT"))=""
206 . D ^%ZTLOAD
207 . D HOME^%ZIS
208 . S ECX=0
209 Q ECX
Note: See TracBrowser for help on using the repository browser.