source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECOSSUM.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: 7.6 KB
Line 
1ECOSSUM ;BIR/DMA,RHK,JPW-Ordering Section Summary ;27 Mar 96
2 ;;2.0; EVENT CAPTURE ;**5,8,18,47,72**;8 May 96
3EN ;entry point from menu option
4 W !
5 K DIC S DIC=723,DIC(0)="AQEMZ",DIC("A")="Select Ordering Section: " D ^DIC K DIC
6 I Y<0 G EXIT
7 S ECOS=+Y,ECOSN=$P(Y,"^",2)
8 D RANGE
9 I '$G(ECLOOP)!'$G(ECSD)!'$G(ECED) G EXIT
10 W !
11 S JJ=$$ASKLOC^ECRUTL
12 I 'JJ G EXIT
13 W !
14 S JJ=$$ASKDSS^ECRUTL
15 I 'JJ G EXIT
16 W !
17 D DEVICE
18 I POP G EXIT
19 I $G(ZTSK) G EXIT
20 I $G(IO("Q")),'$G(ZTSK) G EXIT
21 D START
22 D HOME^%ZIS
23 G EXIT
24 Q
25 ;
26START ;queued entry point or continuation
27 D PROCESS
28 U IO D PRINT
29 I $D(ECGUI) D EXIT Q
30 I IO'=IO(0) D ^%ZISC
31 I $D(ZTQUEUED) S ZTREQ="@" D EXIT
32 Q
33 ;
34RANGE ;get any date range
35 N ECSTDT,ECENDDT
36 W !!,?5,"Enter a Begin Date and End Date for the Event Capture "
37 W !,?5,"Ordering Section report.",!
38 S (ECSD,ECED)=0
39 F D Q:ECSD>0 Q:'$G(ECLOOP)
40 .S ECLOOP=$$STDT^ECRUTL() I 'ECLOOP Q
41 .S ECSD=ECSTDT
42 Q:'$G(ECLOOP)!'$G(ECSD)
43 F D Q:ECED>0 Q:'$G(ECLOOP)
44 .S ECLOOP=$$ENDDT^ECRUTL(ECSTDT) I 'ECLOOP Q
45 .S ECED=ECENDDT
46 .I ECED>(DT+1) D
47 ..W !!,?15,"The End Date for this report may not be"
48 ..W !,?15,"a future date. Try again...",!
49 ..S ECED=0
50 Q
51 ;
52DEVICE ;select output device
53 W !,"This report is formatted for 132 column output.",!
54 K IOP S %ZIS="QM" D ^%ZIS
55 I POP W !!,"No device selected. Exiting...",!! S DIR(0)="E" W ! D ^DIR K DIR Q
56 I $D(IO("Q")) D
57 .S ZTRTN="START^ECOSSUM",ZTDESC="EC Ordering Section Summary"
58 .S ZTSAVE("ECSD")="",ZTSAVE("ECED")="",ZTSAVE("ECOS")="",ZTSAVE("ECOSN")=""
59 .S ZTSAVE("ECLOC(")="",ZTSAVE("ECDSSU(")=""
60 .D ^%ZTLOAD
61 .I '$G(ZTSK) W !,"Report canceled..." S DIR(0)="E" W ! D ^DIR K DIR Q
62 .W !,"Report queued as Task #: ",ZTSK S DIR(0)="E" W ! D ^DIR K DIR
63 Q
64 ;
65PROCESS ;get data to print
66 N EC,ECD,ECDA,ECPA,ECPATN,ECSS,ECSSN,ECP,ECPN,ECLOCA,ECUNIT,ECCAT,ECFILE,ECPSY,ECPSYN,ECPRV,ECPRVN,EC725
67 N NLOC,NUNIT,JJ,ECPXD
68 K ^TMP("ECOS",$J)
69 ;put locations and units into ien subscripted arrays
70 S JJ="" F S JJ=$O(ECLOC(JJ)) Q:JJ="" D
71 .S NLOC($P(ECLOC(JJ),"^",1))=$P(ECLOC(JJ),"^",2)
72 S JJ="" F S JJ=$O(ECDSSU(JJ)) Q:JJ="" D
73 .S NUNIT($P(ECDSSU(JJ),"^",1))=$P(ECDSSU(JJ),"^",2)
74 S ECD=ECSD
75 F S ECD=$O(^ECH("AC",ECD)) Q:'ECD Q:ECD>ECED D
76 .S ECDA="" F S ECDA=$O(^ECH("AC",ECD,ECDA)) Q:'ECDA S EC=$G(^ECH(ECDA,0)) I $P(EC,"^",12)=ECOS D
77 ..I $P(EC,"^",3)<ECSD!($P(EC,"^",3)>ECED) Q ;file or x-ref problem
78 ..S ECLOCA=+$P(EC,U,4),ECUNIT=+$P(EC,U,7)
79 ..I '$D(NLOC(ECLOCA))!('$D(NUNIT(ECUNIT))) Q
80 ..S ECP=$P(EC,U,9) Q:ECP']""
81 ..S ECCAT=+$P(EC,U,8)
82 ..S ECPSY=+$O(^ECJ("AP",ECLOCA,ECUNIT,ECCAT,ECP,""))
83 ..S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2)
84 ..S ECFILE=$P(ECP,";",2),ECFILE=$S($E(ECFILE)="I":81,$E(ECFILE)="E":725,1:"UNKNOWN")
85 ..I ECFILE="UNKNOWN" S ECPN="UNKNOWN"
86 ..S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0)),"^",5)),ECPXD=""
87 ..I ECCPT'="" D
88 ...S ECPXD=$$CPT^ICPTCOD(ECCPT,$P(EC,"^",3)),ECCPT=$P(ECPXD,"^",2)
89 ..I ECFILE=81 S ECPN=$S($P(ECPXD,"^",3)]"":$P(ECPXD,"^",3),1:"UNKNOWN")
90 ..I ECFILE=725 D
91 ...S EC725=$G(^EC(725,+ECP,0)),ECPN=$P(EC725,"^",2)_" "_$P(EC725,"^")
92 ..S ECPN=$E(ECPN,1,37)_$S(ECPSYN]"":" ["_ECPSYN_"] ",1:"")_"~"_ECCPT
93 ..;ALB/JAM - Get Procedure CPT modifiers
94 ..S ECMODF=0 I $O(^ECH(ECDA,"MOD",0))'="" D
95 ...K ECMOD S ECMODF=$$MOD^ECUTL(ECDA,"E",.ECMOD)
96 ..S (ECPA,ECPATN,ECSS)="",ECPA=$G(^DPT(+$P(EC,"^",2),0)) Q:ECPA=""
97 ..S ECPATN=$P(ECPA,"^",1),ECSS=$P(ECPA,"^",9)
98 ..S:+ECSS ECSSN=$E(ECSS,6,10) S:ECSS="" ECSSN="UNKN"
99 ..S:ECPATN="" ECPATN="UNKNOWN" S ECPATN=ECPATN_"^"_ECSSN
100 ..S ECV=+$P(EC,"^",10)
101 ..K ECPRV S ECPRV=$$GETPRV^ECPRVMUT(ECDA,.ECPRV) I 'ECPRV D K ECPRV
102 ...M ^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA,"PRV")=ECPRV
103 ..S ^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA)=ECSSN_"^"_ECPN_"^"_ECV
104 ..I ECMODF D
105 ...M ^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA,"MOD")=ECMOD
106 Q
107 ;
108PRINT ;output report
109 N ECDA,ECLOCA,ECUNIT,ECPATN,ECSSN,ECPN,ECV
110 N PAGE,QFLAG,DASH,DASH2,PRNTDT,JJ,SS,ALOC,AUNIT,LOC,UNNAME,UNIT,DATA,PTNAME,PROV,PROVN,V,X,Y
111 S (PAGE,QFLAG)=0 S $P(DASH,"-",130)="",$P(DASH2,"-",64)=""
112 S Y=$P(ECSD,".",1)+1 D DD^%DT S ECSD=Y S Y=$P(ECED,".",1) D DD^%DT S ECED=Y
113 D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S PRNTDT=Y
114 S ECV("L")=0,ECV("O")=0,ECV("P")=0,ECV("U")=0
115 ;if no data exists then print the header and quit
116 I '$D(^TMP("ECOS",$J)) D Q
117 .S LOC="" D HEAD
118 .W !!,?26,"No data for this Ordering Section for the date range specified.",!!
119 .I $E(IOST)="C"&('QFLAG) S DIR(0)="E" D D ^DIR K DIR
120 ..S SS=22-$Y F JJ=1:1:SS W !
121 .W:$E(IOST)'="C" @IOF
122 ;if there's data in ^TMP then need to present the data alphabetically;
123 ;put locations and units in alpha ordered array
124 S JJ="" F S JJ=$O(ECLOC(JJ)) Q:JJ="" D
125 .S ALOC($P(ECLOC(JJ),"^",2))=$P(ECLOC(JJ),"^",1)
126 S JJ="" F S JJ=$O(ECDSSU(JJ)) Q:JJ="" D
127 .S AUNIT($P(ECDSSU(JJ),"^",2))=$P(ECDSSU(JJ),"^",1)
128 ;process the ^TMP global data in alpha order for location and unit
129 S LOC="" F S LOC=$O(ALOC(LOC)) Q:LOC="" S ECLOCA=ALOC(LOC),ECV("L")=0 D Q:QFLAG
130 .D HEAD Q:QFLAG ;always start a new location at top of page
131 .S UNIT="" F S UNIT=$O(AUNIT(UNIT)) Q:UNIT="" S ECUNIT=AUNIT(UNIT),ECV("U")=0 D Q:QFLAG
132 ..I '$D(^TMP("ECOS",$J,ECLOCA,ECUNIT)) Q
133 ..S UNNAME=$E(UNIT,1,20)
134 ..D:($Y+3>IOSL) HEAD Q:QFLAG W !!,UNNAME
135 ..S ECPATN="" F S ECPATN=$O(^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN)) Q:ECPATN="" S ECV("P")=0 D Q:QFLAG
136 ...S PTNAME=$P(ECPATN,"^",1),PTNAME=$E(PTNAME,1,22),ECSSN=$P(ECPATN,"^",2)
137 ...W ?24,PTNAME,?48,ECSSN
138 ...S ECDA="" F S ECDA=$O(^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA)) Q:ECDA="" S DATA=^(ECDA) D Q:QFLAG
139 ....S ECPN=$P(DATA,"^",2),ECPN=$J($P(ECPN,"~",2)_" ",6)_$P(ECPN,"~")
140 ....S ECPN=$E(ECPN,1,41),ECV=$P(DATA,"^",3),ECV=ECV\1 D
141 .....F V="L","O","P","U" S ECV(V)=ECV(V)+ECV
142 .....S:+ECV>9999 ECV="9999+" S ECV=$$RJ^XLFSTR(ECV,5," ") ;unusually high individual volume figure
143 ....K PROV M PROV=^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA,"PRV")
144 ....K ECMOD M ECMOD=^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA,"MOD")
145 ....W ?54,ECPN,?96,ECV,?105,$E($P($G(PROV(1)),"^",2),1,24) K PROV(1)
146 ....D:($Y+3>IOSL) HEAD Q:QFLAG
147 ....;ALB/JAM - write cpt procedure modifiers on same line with providers
148 ....S MOD=0,PROVN=1 F S MOD=$O(ECMOD(MOD)),PROVN=$O(PROV(PROVN)) Q:(MOD="")&(PROVN="") D I QFLAG Q
149 .....I ($Y+3>IOSL) D HEAD Q:QFLAG W !?54,ECPN
150 .....W !
151 .....I MOD'="" W ?58,"- ",MOD," ",$E($P(ECMOD(MOD),U,3),1,36) K ECMOD(MOD)
152 .....I PROVN'="" W ?105,$E($P($G(PROV(PROVN)),"^",2),1,24) K PROV(PROVN)
153 ....W ! ;start a new line
154 ...;write subtotal for patient
155 ...Q:QFLAG D:($Y+3>IOSL) HEAD Q:QFLAG
156 ...W ?54,DASH2,!
157 ...W ?24,"Subtotal for "_$P(ECPATN,"^",1)_":",?96,$$RJ^XLFSTR(ECV("P"),5," "),!!
158 ..;write total for unit
159 ..Q:QFLAG D:($Y+3>IOSL) HEAD Q:QFLAG
160 ..W !,"Subtotal for DSS Unit "_UNIT_":",?95,$$RJ^XLFSTR(ECV("U"),6," "),!
161 .;write the total for the location
162 .Q:QFLAG D:($Y+3>IOSL) HEAD Q:QFLAG
163 .W !!,"Total for Location "_LOC_":",?95,$$RJ^XLFSTR(ECV("L"),6," "),!
164 ;write the ordering section grandtotal
165 Q:QFLAG D:($Y+5>IOSL) HEAD Q:QFLAG
166 W !!!,"Grand Total for Ordering Section "_ECOSN_":",?95,$$RJ^XLFSTR(ECV("O"),6," "),!
167 ;all done
168 I $E(IOST)="C"&('QFLAG) S DIR(0)="E" D D ^DIR W @IOF
169 .S SS=22-$Y F JJ=1:1:SS W !
170 W:$E(IOST)'="C" @IOF
171 Q
172HEAD ;header
173 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
174 I $E(IOST)="C",PAGE>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLAG=1 Q
175 W:$Y!($E(IOST)="C") @IOF
176 S PAGE=PAGE+1
177 W !,?26,"Event Capture Ordering Section Summary for ",ECOSN,?105,"Page: ",PAGE
178 W !,?26,"for the Date Range ",$$FMTE^XLFDT(ECSD)," to ",$$FMTE^XLFDT(ECED),?102,"Printed: "_PRNTDT
179 W !,?26,"Location: ",LOC,!
180 W !,"DSS Unit",?24,"Patient",?48,"SSN",?54,"Procedure",?98,"Vol.",?105,"Provider(s)"
181 W !,DASH,!
182 Q
183 ;
184EXIT ;common exit point
185 D ^ECKILL
186 D:'$D(ECGUI) ^%ZISC
187 K ^TMP("ECOS",$J)
188 K JJ,X,Y,ZTSK,IO("Q"),DIR,DIRUT,DTOUT,DUOUT,ECOS,ECOSN,ECSD,ECED,ECLOOP,ECLOC,ECDSSU
189 Q
Note: See TracBrowser for help on using the repository browser.