source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECRPRSN.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.5 KB
Line 
1ECRPRSN ;ALB/JAP - Procedure Reasons Report;24 JAN 07
2 ;;2.0; EVENT CAPTURE ;**5,18,47,63,72,91**;8 May 96;Build 2
3EN ;entry point from menu option
4 N JJ
5 W ! S JJ=$$ASKLOC^ECRUTL I 'JJ G EXIT
6 W ! S JJ=$$ASKDSS^ECRUTL I 'JJ G EXIT
7 W ! S JJ=$$ASKREAS() I 'JJ G EXIT
8 W !
9 D RANGE
10 I '$G(ECLOOP)!'$G(ECSD)!'$G(ECED) G EXIT
11 W ! D DEVICE I POP G EXIT
12 I $G(ZTSK) G EXIT
13 I $G(IO("Q")),'$G(ZTSK) G EXIT
14 D START,HOME^%ZIS
15 G EXIT
16 Q
17START ;queued entry point or continuation
18 D PROCESS
19 U IO D PRINT Q:$D(ECGUI)
20 I IO'=IO(0) D ^%ZISC
21 I $D(ZTQUEUED) S ZTREQ="@" D EXIT
22 Q
23ASKREAS() ; Ask reasons
24 ; output: ECREAS array; contains set of reason iens
25 N DIRUT,DUOUT,DTOUT,Y,DIR,A,P,R,S,JJ,KK,NLOC,NUNIT,LINK,ECREAS,E
26 ;setup array of associated reason iens for the locations/units included
27 W !!,"Just a moment please..."
28 W !,?5,"...finding Procedure Reasons related to the"
29 W !,?5," Location(s) and DSS Unit(s) you selected...",!
30 S JJ="" F S JJ=$O(ECLOC(JJ)) Q:JJ="" D
31 .S NLOC=$P(ECLOC(JJ),"^",1)
32 .S KK="" F S KK=$O(ECDSSU(KK)) Q:KK="" S NUNIT=$P(ECDSSU(KK),"^",1),A(NLOC_"-"_NUNIT)=""
33 S P=""
34 F S P=$O(^ECJ("B",P)) Q:P="" I $D(A($P(P,"-",1,2))) S I=$O(^ECJ("B",P,"")),S(I)=""
35 K A S P="" F S P=$O(^ECL("AD",P)) Q:P="" I $D(S(P)) S R="" D
36 .F S R=$O(^ECL("AD",P,R)) Q:R="" D
37 ..S LINK=$O(^ECL("AD",P,R,"")),ECLINK(LINK)=R
38 ..S ECREAS(R)=$P($G(^ECR(R,0)),"^",1)
39 ..I ECREAS(R)="" K ECREAS(R),ECLINK(LINK)
40 K S
41 ;ask the user to include all reasons or selected reasons
42 S ASK=1
43 S DIR(0)="YA",DIR("A")="Do you want to print this report for all Procedure Reasons? "
44 S DIR("B")="YES" W ! D ^DIR K DIR I Y=0,'$G(DIRUT) D SPECR
45 I $G(DIRUT)!(Y=0) S ASK=0 K ECREAS
46 ;display user selections
47 I $D(ECREAS)>1 D
48 .W @IOF S E=0 W !,"Selected Procedure Reasons --",!
49 .S R="" F S R=$O(ECREAS(R)) Q:R="" D I E Q
50 ..I $Y+3>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y E=1 Q:'Y D
51 ...W @IOF,!,"Selected Procedure Reasons (cont.) --",!
52 ..W !,?5,ECREAS(R)
53 .Q:E S DIR(0)="E" D D ^DIR K DIR
54 ..S SS=22-$Y F JJ=1:1:SS W !
55 Q ASK
56SPECR ;specific reasons
57 N R,DUOUT,DTOUT
58 K DIRUT,Y
59 S DIR(0)="YA",DIR("A")="Do you want to include only specific Procedure Reasons in this report? ",DIR("B")="YES"
60 S DIR("?")="Enter YES to select specific Procedure Reasons or NO to quit."
61 W ! D ^DIR K DIR Q:$G(DIRUT)!(Y=0)
62 ;select subset of possible reasons
63 K DIRUT,DTOUT,DUOUT,Y
64 F D Q:$G(DIRUT)!(Y=-1)
65 .S DIC=720.4,DIC("A")="Select a Procedure Reason to include: ",DIC(0)="QAEM"
66 .S DIC("S")="I $D(ECREAS(+Y))"
67 .W ! D ^DIC Q:$G(DUOUT)!$G(DTOUT)!(Y=-1)
68 .S R(+Y)=""
69 S:$G(DTOUT)!($G(DUOUT)) DIRUT=1
70 Q:$G(DIRUT)
71 ;delete reasons from ecreas array which were not selected
72 I $D(R)<10 S Y=0 Q
73 S R="" F S R=$O(ECREAS(R)) Q:R="" I '$D(R(R)) K ECREAS(R)
74 ;delete links from eclink array for reasons not selected
75 S LINK="" F S LINK=$O(ECLINK(LINK)) Q:LINK="" S R=ECLINK(LINK) I '$D(ECREAS(R)) K ECLINK(LINK)
76 S Y=1
77 Q
78RANGE ;get any date range
79 N ECSTDT,ECENDDT
80 W !!!,?5,"Enter a Begin Date and End Date for the Event Capture "
81 W !,?5,"Procedure Reason Report.",!
82 S (ECSD,ECED)=0
83 F D Q:ECSD>0 Q:'$G(ECLOOP)
84 .S ECLOOP=$$STDT^ECRUTL() I 'ECLOOP Q
85 .S ECSD=ECSTDT
86 Q:'$G(ECLOOP)!'$G(ECSD)
87 F D Q:ECED>0 Q:'$G(ECLOOP)
88 .S ECLOOP=$$ENDDT^ECRUTL(ECSTDT) I 'ECLOOP Q
89 .S ECED=ECENDDT
90 .I ECED>(DT+1) D
91 ..W !!,?15,"The End Date for this report may not be"
92 ..W !,?15,"a future date. Try again...",!
93 ..S ECED=0
94 Q
95 ;
96DEVICE ;select output device
97 W ! K IOP,ZTSK S %ZIS="QM" D ^%ZIS
98 I POP W !!,"No device selected. Exiting...",!! S DIR(0)="E" W ! D ^DIR K DIR Q
99 I $D(IO("Q")) D
100 .S ZTRTN="START^ECRPRSN",ZTDESC="EC Procedure Reason Report"
101 .S ZTSAVE("ECSD")="",ZTSAVE("ECED")="",ZTSAVE("ECLOC(")="",ZTSAVE("ECDSSU(")="",ZTSAVE("ECLINK(")=""
102 .D ^%ZTLOAD D HOME^%ZIS
103 .I '$G(ZTSK) W !,"Report canceled..." S DIR(0)="E" W ! D ^DIR K DIR Q
104 .W !,"Report queued as Task #: ",ZTSK S DIR(0)="E" W ! D ^DIR K DIR
105 Q
106 ;
107PROCESS ;get data to print
108 N EC,ECD,ECDA,ECPA,ECR,ECRL,ECRN,ECPATN,ECSS,ECSSN,ECP,ECPN,ECLOCA
109 N ECUNIT,ECCAT,ECFILE,ECPSY,ECPSYN,ECPRV,ECPRVN,ECDFN,ECCPT,ECDESC
110 N NLOC,NUNIT,JJ,ECMOD,ECMD,ECMODF,EC725
111 K ^TMP("ECREAS",$J)
112 ;if ecreas array doesn't exist, quit
113 I $D(ECLINK)<10 Q
114 ;put locations and units into ien subscripted arrays
115 S JJ="" F S JJ=$O(ECLOC(JJ)) Q:JJ="" D
116 .S NLOC($P(ECLOC(JJ),"^",1))=$P(ECLOC(JJ),"^",2)
117 S JJ="" F S JJ=$O(ECDSSU(JJ)) Q:JJ="" D
118 .S NUNIT($P(ECDSSU(JJ),"^",1))=$P(ECDSSU(JJ),"^",2)
119 S ECD=ECSD F S ECD=$O(^ECH("AC",ECD)) Q:'ECD Q:ECD>ECED D
120 .S ECDA="" F S ECDA=$O(^ECH("AC",ECD,ECDA)) Q:'ECDA S EC=$G(^ECH(ECDA,0)) I $P(EC,"^",23)'="" D
121 ..S ECDFN=$P(EC,"^")
122 ..I $P(EC,"^",3)<ECSD!($P(EC,"^",3)>ECED) Q ;file or x-ref problem
123 ..S ECLOCA=+$P(EC,U,4),ECUNIT=+$P(EC,U,7)
124 ..I '$D(NLOC(ECLOCA))!('$D(NUNIT(ECUNIT))) Q
125 ..S ECRL=$P(EC,"^",23) Q:'$D(ECLINK(ECRL)) S ECR=ECLINK(ECRL),ECRN=$P($G(^ECR(ECR,0)),"^") Q:ECRN']""
126 ..S ECP=$P(EC,U,9) Q:ECP']""
127 ..S ECCAT=+$P(EC,U,8),ECPSY=+$O(^ECJ("AP",ECLOCA,ECUNIT,ECCAT,ECP,""))
128 ..S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2),ECPI=""
129 ..S ECFILE=$P(ECP,";",2),ECFILE=$S($E(ECFILE)="I":81,$E(ECFILE)="E":725,1:"UNKNOWN")
130 ..S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0)),"^",5))
131 ..I ECCPT'="" D
132 ...S ECPI=$$CPT^ICPTCOD(ECCPT,$P(ECED,".")) I +ECPI>1 S ECCPT=$P(ECPI,"^",2)_" "
133 ..I ECFILE="UNKNOWN" S ECPN="UNKNOWN"
134 ..I ECFILE=81 S ECPN=$S($P(ECPI,"^",3)]"":$P(ECPI,"^",3),1:"UNKNOWN")
135 ..I ECFILE=725 S EC725=$G(^EC(725,+ECP,0)),ECPN=$P(EC725,"^",2)_" "_$P(EC725,"^")
136 ..Q:ECPN=""
137 ..S ECDESC=$J(ECCPT_" ",6)_$E(ECPN,1,40)_$S(ECPSYN]"":" ["_ECPSYN_"] ",1:"")
138 ..S (ECPA,ECPATN,ECSS)="",ECPA=$G(^DPT(+$P(EC,"^",2),0)) Q:ECPA=""
139 ..S ECPATN=$E($P(ECPA,"^",1),1,24),ECSS=$P(ECPA,"^",9)
140 ..S:+ECSS ECSSN=$E(ECSS,6,9) S:ECSS="" ECSSN="UNKNOWN"
141 ..S:ECPATN="" ECPATN="UNKNOWN" S ECPATN=ECPATN_"^"_ECSSN
142 ..S (ECPRV,ECPRVN)="",ECPRV=$$GETPPRV^ECPRVMUT(ECDA,.ECPRVN),ECPRVN=$S(ECPRV:"UNKNOWN",1:ECPRVN)
143 ..S ECMD="" I $O(^ECH(ECDA,"MOD",0))'="" D ;ALB/JAM - Get CPT modifiers
144 ...K ECMOD S ECMODF=$$MOD^ECUTL(ECDA,"I",.ECMOD),SEQ="" I 'ECMODF Q
145 ...F S SEQ=$O(ECMOD(SEQ)) Q:SEQ="" S ECMD=ECMD_$S(ECMD="":"",1:";")_$P(ECMOD(SEQ),"^",2)
146 ..I ECMD="" S ECMD="NOMOD"
147 ..S ^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECRN,$E(ECPN,1,15))=ECDESC
148 ..S ^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECRN,$E(ECPN,1,15),ECMD,ECDFN,ECD)=ECPRVN_"^"_ECPATN
149 ..;where ecloca, ecunit,ecdfn are iens, ecdt is internal format
150 Q
151PRINT ;output report
152 N ECLOCA,ECUNIT,ECREASN,ECDT,ECED2,ECSD2,ECPATN,ECPN,ECPRVN,SEQ,X,Y,SSN
153 N PAGE,QFLAG,DASH,PRNTDT,JJ,SS,ALOC,AUNIT,DATE,LOC,UNIT,PTNAME,PROVN,ECDESC
154 S (PAGE,QFLAG)=0 S $P(DASH,"-",80)=""
155 S Y=$P(ECSD,".",1)+1 D DD^%DT S ECSD2=Y S Y=$P(ECED,".",1) D DD^%DT S ECED2=Y
156 D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S PRNTDT=Y
157 ;if no data exists then print the header and quit
158 I '$D(^TMP("ECREAS",$J)) D Q
159 .S (LOC,UNIT)="" D HEAD
160 .W !!,?6,"No data for the date range specified.",!!
161 .I $E(IOST)="C"&('QFLAG) S DIR(0)="E" D D ^DIR K DIR
162 ..S SS=22-$Y F JJ=1:1:SS W !
163 .W:$E(IOST)'="C" @IOF
164 ;if there's data in ^TMP then need to present the data alphabetically;
165 ;put locations and units in alpha ordered array
166 S JJ="" F S JJ=$O(ECLOC(JJ)) Q:JJ="" D
167 .S ALOC($P(ECLOC(JJ),"^",2))=$P(ECLOC(JJ),"^",1)
168 S JJ="" F S JJ=$O(ECDSSU(JJ)) Q:JJ="" D
169 .S AUNIT($P(ECDSSU(JJ),"^",2))=$P(ECDSSU(JJ),"^",1)
170 ;process the ^TMP global data in alpha order for location and unit
171 S LOC="" F S LOC=$O(ALOC(LOC)) Q:LOC="" S ECLOCA=ALOC(LOC) D Q:QFLAG
172 .S UNIT="" F S UNIT=$O(AUNIT(UNIT)) Q:UNIT="" S ECUNIT=AUNIT(UNIT) D Q:QFLAG
173 ..;always start a location at top of page
174 ..I $D(^TMP("ECREAS",$J,ECLOCA,ECUNIT)) D HEAD D LOOP
175 ;all done
176 I $E(IOST)="C"&('QFLAG) S DIR(0)="E" D D ^DIR W @IOF
177 .S SS=22-$Y F JJ=1:1:SS W !
178 W:$E(IOST)'="C" @IOF
179 Q
180LOOP ;print the section of the ^tmp global for a specific location/unit
181 S ECREASN=""
182 F S ECREASN=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN)) Q:ECREASN="" Q:QFLAG D
183 .D:($Y+3>IOSL) HEAD Q:QFLAG W !!,"Reason: ",ECREASN,! S ECPN=""
184 .F S ECPN=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN)) Q:ECPN="" Q:QFLAG D
185 ..S ECDESC=$G(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN)),ECMOD=""
186 ..F S ECMOD=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN,ECMOD)) Q:ECMOD="" D Q:QFLAG
187 ...W !,?3,"Procedure: ",ECDESC D:ECMOD'="NOMOD" MODPRT Q:QFLAG D LOOP1
188 Q
189LOOP1 S ECPATN="" F S ECPATN=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN,ECMOD,ECPATN)) Q:ECPATN="" Q:QFLAG D
190 .S ECDT="" F S ECDT=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN,ECMOD,ECPATN,ECDT)) Q:ECDT="" Q:QFLAG D
191 ..S ECPRVN=^(ECDT),PTNAME=$P(ECPRVN,"^",3),PTNAME=$E(PTNAME,1,22)
192 ..S SSN=$P(ECPRVN,"^",4),ECPRVN=$P(ECPRVN,"^",2)
193 ..S Y=ECDT D DD^%DT S DATE=$E(Y,1,18),PROVN=$E(ECPRVN,1,22)
194 ..D:($Y+3>IOSL) HEAD Q:QFLAG W !,?6,PTNAME,?30,SSN,?37,DATE,?57,PROVN
195 W !
196 Q
197MODPRT ;ALB/JAM - print CPT procedure modifiers
198 N MOD,I,MODESC,IEN,MODI
199 W !?4,"Modifier: "
200 F I=1:1 S IEN=$P(ECMOD,";",I) Q:IEN="" D I QFLAG Q
201 . S MODI=$$MOD^ICPTMOD(IEN,"E",$P(ECED,".")),MOD=$P(MODI,"^",2) I MOD="" Q
202 . S MODESC=$P(MODI,"^",3) I MODESC="UNKNOWN" Q
203 . W:I>1 ! W ?18,"- ",MOD," ",MODESC I ($Y+3)>IOSL D HEAD
204 Q
205HEAD ;header
206 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
207 I $E(IOST)="C",PAGE>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLAG=1 Q
208 W:$Y!($E(IOST)="C") @IOF
209 S PAGE=PAGE+1
210 W !,?12,"Event Capture Procedure Reason Report"
211 W !,?12,"for the Date Range ",$$FMTE^XLFDT(ECSD2)," to ",$$FMTE^XLFDT(ECED2),!
212 W !,?3,"DSS Unit: ",UNIT,?55,"Page: ",PAGE
213 W !,?3,"Location: ",LOC,?52,"Printed: "_PRNTDT,!
214 W !?6,"Patient",?30,"SSN",?37,"Date/Time",?57,"Provider"
215 W !,DASH
216 Q
217EXIT ;common exit point
218 D ^ECKILL D:'$D(ECGUI) ^%ZISC
219 K ^TMP("ECREAS",$J) K JJ,X,Y,ZTSK,IO("Q"),DIR,DIRUT,DTOUT,DUOUT,ECSD
220 K ECED,ECLOOP,ECLOC,ECDSSU,ECLINK,ASK,DIC
221 Q
Note: See TracBrowser for help on using the repository browser.