source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECMUTL.m@ 1328

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1ECMUTL ;ALB/ESD - Utilities for Multiple Dates/Mult Procs ;20 AUG 1997 13:56
2 ;;2.0; EVENT CAPTURE ;**5,10,18,33,47,63**;8 May 96
3 ;
4ASKLOC() ; Get Location
5 ; Input: None
6 ;
7 ; Output: ECL = Location (Division file pointer) ien
8 ; ECLN = Location name
9 ;
10 D ^ECL
11 K ECOUT,LOC
12 Q $S($D(ECL):1,1:0)
13 ;
14 ;
15ASKPRDT(DSSU,ONE) ; Get Procedure Start Date/Time
16 ; Input: ECD = DSS Unit ien
17 ; ONE = Ask procedure start date/time once
18 ;
19 ; Output: ^TMP("ECPRDT",$J) = procedure date/time array
20 ;
21 N DTOUT,DUOUT,ECCNT,ECDUP,ECERR
22 S (ECCNT,ECDUP,ECERR)=0
23 I '$G(DSSU) G ASKPRDTQ
24 I $P($G(^ECD(DSSU,0)),"^",12)="N" S DIR("B")="NOW"
25AGAIN N DIRUT,Y
26 S DIR("A")="Select "_$S(+ECDUP:"Another Procedure Date and Time",1:"Procedure Date and Time")
27 S DIR("?")="Enter both date AND time procedure was performed. Future dates are not allowed."
28 S DIR(0)="DO^:NOW:EXR"
29 D ^DIR K DIR
30 I $D(DTOUT)!($D(DUOUT)) S ECERR=1
31 I +Y S ECDUP=1,^TMP("ECPRDT",$J,Y)="" G @($S('$G(ONE):"AGAIN",1:"ASKPRDTQ"))
32 ;
33ASKPRDTQ Q $S(ECERR:0,(+$G(ONE)&(+Y)):1,('$G(ONE))&($D(^TMP("ECPRDT",$J))):1,1:0)
34 ;
35 ;
36ASKCAT(ECL,ECD) ; Get category
37 ; Input: ECL = Location ien
38 ; ECD = DSS Unit ien
39 ;
40 ; Output: ECATEG = Category ien (may be 0 if no categories)
41 ;
42 N CATS,DIRUT,ECATEG,ECMAX,X
43 S ECATEG=0_"^No Categories",(ECMAX,X)=0
44 I '$G(ECL)!('$G(ECD)) G ASKCATQ
45 D CATS^ECHECK1
46 I $O(ECC(0))']"" G ASKCATQ
47 W !!,"Categories within "_$P($G(^ECD(+ECD,0)),"^")_":",!
48 F S X=$O(ECC(X)) Q:'X W !?5,X_". ",$P(ECC(X),"^",2) S ECMAX=X
49 W ! S DIR(0)="NA^1:"_ECMAX,DIR("A")="Select Number: "
50 D ^DIR K DIR
51 I 'Y!($D(DIRUT)) K ECATEG G ASKCATQ
52 I +Y S ECATEG=$G(ECC(Y))
53ASKCATQ K CNT,ECAT,ECC
54 Q $G(ECATEG)
55 ;
56 ;
57ASKPRO(ECL,ECD,ECC,NUM) ; Ask procedures
58 ; Input: ECL = Location ien
59 ; ECD = DSS Unit ien
60 ; ECC = Category ien
61 ; NUM = Only ask procedure once
62 ;
63 ; Output: ^TMP("ECPROC",$J) = procedure array
64 ;
65 N CNT,ECERR,ECOUNT,ECOUT,ECPCNT,ECP,ECPNM,ECPREV,ECREAS,ECVOLU,ECEXIT
66 N ECX,ECMOD,ECMODS,ECCPT,ECDT
67 I '$D(ECL)!('$D(ECD)) G ASKPROQ
68 S ECC=+$G(ECC)
69 S ECOUNT=0
70 S ECDT=$O(^TMP("ECPRDT",$J,0))
71 D PROS^ECHECK1
72 I '$O(^TMP("ECPRO",$J,0)) D G ASKPROQ
73 . W !!,"Within the ",ECLN," location there are no procedures defined",!
74 . W "for the DSS Unit ",$P(ECDSSU,"^",2),".",!
75 . S DIR(0)="E" D ^DIR K DIR,Y
76 ;
77SEL ;
78 K ECPNAME,ECMOD
79 S (ECPNM,ECPREV,ECREAS,ECX)="",(CNT,ECPCNT,ECP,ECVOLU,ECEXIT)=0
80 S DIR("?")="^D LISTPR^ECMUTL"
81 W ! S ECX=$$GETPRO^ECDSUTIL
82 I +$G(ECX)=-1,('ECOUNT) D MSG^ECBEN2U,KILLV^ECDSUTIL G ASKPROQ
83 I +$G(ECX)=-1,ECOUNT G ASKPROQ
84 I +$G(ECX)=1 S ECPREV=$P(ECX,"^",2) D SRCHTM^ECDSUTIL(ECX)
85 S ECPCNT=+$G(ECPCNT)
86 I ECPCNT=-1!(ECPCNT=-2) D G SEL
87 . D @($S(ECPCNT=-1:"ERRMSG^ECDSUTIL",ECPCNT=-2:"ERRMSG2^ECDSUTIL"))
88 . D KILLV^ECDSUTIL
89 I ECPCNT>0 D D CONTINU G:$G(ECERR) ASKPROQ
90 . S CNT=ECPCNT
91 . I ECPREV="L" W $P($G(^TMP("ECPRO",$J,+$G(^TMP("ECLKUP",$J,"LAST")))),"^",4)
92 . I ECPREV="X"!(ECPREV="N") W " "_$P($G(^TMP("ECPRO",$J,+CNT)),"^",4)
93 I 'ECPCNT,$D(ECPNAME) D G:CNT=-1!($G(ECERR)) ASKPROQ
94 . S CNT=$$PRLST^ECDSUTIL
95 . I CNT=-1 D MSG^ECBEN2U,KILLV^ECDSUTIL Q
96 . I CNT>0 D
97 .. W " "_$S(ECPREV="S":$P($G(^TMP("ECPRO",$J,+CNT)),"^",3),1:$P($G(^TMP("ECPRO",$J,+CNT)),"^",4))
98 .. D CONTINU
99 ;
100 I CNT>0,($G(ECP)'=""),(ECVOLU>0) D
101 . S ECOUNT=$S(+$G(NUM)=-99:1,+$G(NUM)>0:NUM,1:(ECOUNT+1))
102 . S ^TMP("ECPROC",$J,(ECOUNT))=ECP_"^"_ECPNM_"^"_+ECREAS_"^"_$S(+ECREAS:$P($G(^ECR($P($G(^ECL(+ECREAS,0)),"^"),0)),"^"),1:"Reason Not Defined")_"^"_ECVOLU
103 . S ECCPT=$S(ECP["EC":$P($G(^EC(725,+ECP,0)),"^",5),1:+ECP)
104 . I ECCPT'="",$O(ECMOD(ECCPT,""))'="" D
105 . . M ^TMP("ECPROC",$J,ECOUNT,"MOD")=ECMOD(ECCPT)
106 I '$G(NUM) G SEL
107ASKPROQ K ^TMP("ECPRO",$J),^TMP("ECLKUP",$J),JJ,OK
108 D KILLV^ECDSUTIL
109 Q
110 ;
111CONTINU ;
112 D SETP
113 S ECCPT=$S(ECP["EC":$P($G(^EC(725,+ECP,0)),"^",5),1:+ECP)
114 I ECCPT'="" D I $G(ECERR) G CONTINUQ
115 . S ECMODS=$G(ECMODS)
116 . S ECMODF=$$ASKMOD^ECUTL(ECCPT,ECMODS,ECDT,.ECMOD,.ECERR)
117 . K ECMODF,ECMODS
118 S ECREAS=$$ASKREAS(ECL,ECD,ECC,ECP,.ECERR)
119 G:$G(ECERR) CONTINUQ
120 S ECVOLU=$$ASKVOL(ECL,ECD,ECC,ECP,.ECERR)
121CONTINUQ Q
122 ;
123SETP ;
124 S ^TMP("ECLKUP",$J,"LAST")=CNT
125 S ECP=$P($G(^TMP("ECPRO",$J,CNT)),"^"),ECPNM=$P($G(^TMP("ECPRO",$J,CNT)),"^",4)
126 Q
127 ;
128LISTPR ;- List available procedures
129 ; Input: None
130 ;
131 ; Output: None (display on screen)
132 ;
133 N DIR,DIRUT,ECI,Y
134 S ECI=0
135 D PROCHDR
136 F S ECI=$O(^TMP("ECPRO",$J,ECI)) Q:'ECI!(ECEXIT) D
137 . I ($Y+5>IOSL) S DIR(0)="E" D ^DIR S:'Y!$D(DIRUT) ECEXIT=1 I +Y D PROCHDR
138 . Q:ECEXIT
139 . W !,ECI_".",?5,$E($P(^TMP("ECPRO",$J,ECI),"^",4),1,30),?38,$E($P(^(ECI),"^",3),1,30),?72,$P(^(ECI),"^",5)
140 Q:ECEXIT
141 W !!?5,"Select by number, CPT or national code, procedure name, or synonym.",!?5,"Synonym must be preceded by the & character (example: &TESTSYN).",!
142 W ?2,"** Modifier(s) can be appended to a CPT code (ex: CPT code-mod1,mod2,mod3) **",!
143LISTPRQ Q
144 ;
145PROCHDR ;- Procedure display header
146 ;
147 W @IOF
148 W !,"Available Procedures within "_$P(ECDSSU,"^",2)_": ",!
149 W ?72,"National",!,?5,"Procedure Name",?40,"Synonym",?72,"Number",!
150 Q
151 ;
152 ;
153ASKREAS(ECL,ECD,ECC,ECP,ECOUT) ;-Ask procedure reason
154 ; Input: ECL = Location ien
155 ; ECD = DSS Unit ien
156 ; ECC = Category ien
157 ; ECP = Procedure ien
158 ;
159 ; Output: ECPRPTR = Link file ien (from file #720.5)
160 ; ECOUT = 0 if successful
161 ; 1 if uparrowed or timed out
162 ; (passed by reference)
163 ;
164 N DTOUT,DUOUT,ECPRPTR,ECSCR
165 S (ECOUT,ECPRPTR,ECSCR)=0
166 S ECC=+$G(ECC)
167 I '$D(ECL)!('$D(ECD))!('$D(ECP)) G ASKREASQ
168 I $G(ECP)]"" S ECSCR=+$O(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0))
169 I ECSCR>0,(+$P($G(^ECJ(ECSCR,"PRO")),"^",5)),(+$O(^ECL("AD",ECSCR,0))) D
170 . S DIC="^ECL(",DIC(0)="QEAM"
171 . S DIC("A")="Procedure Reason: ",DIC("S")="I $P(^(0),U,2)=ECSCR"
172 . D ^DIC K DIC
173 . I +Y>0 S ECPRPTR=+Y
174 . I $D(DTOUT)!($D(DUOUT)) S ECOUT=1
175ASKREASQ Q +ECPRPTR
176 ;
177 ;
178ASKVOL(ECL,ECD,ECC,ECP,ECOUT) ;- Ask procedure volume
179 ; Input: ECL = Location ien
180 ; ECD = DSS Unit ien
181 ; ECC = Category ien
182 ; ECP = Procedure ien
183 ;
184 ; Output: ECVOL = volume
185 ; ECOUT = 0 if successful
186 ; 1 if uparrowed or timed out
187 ; (passed by reference)
188 ;
189 N DIR,DIRUT,DTOUT,DUOUT,ECSCR,ECVOL
190 S (ECOUT,ECSCR,ECVOL)=0
191 S ECC=+$G(ECC)
192 I '$D(ECL)!('$D(ECD))!('$D(ECP)) G ASKVOLQ
193 I $G(ECP)]"" S ECSCR=+$O(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0))
194 S DIR(0)="N^^K:(X<1)!(X>99) X",DIR("A")="Volume"
195 S DIR("?")="Type a Number between 1 and 99, 0 Decimal Digits"
196 S DIR("B")=$S($P($G(^ECJ(ECSCR,"PRO")),"^",3):$P($G(^ECJ(ECSCR,"PRO")),"^",3),1:1)
197 D ^DIR
198 I +Y S ECVOL=Y
199 I $D(DIRUT) S ECOUT=1
200ASKVOLQ Q +ECVOL
201 ;
202 ;
203PROV(ECDT,ECPROVS) ;get providers - new providers function
204 ;- This is the same function as PROV^ECPRVUTL
205 ;- Select provider(s) with active person class
206 ;- No updating of file #721 record is done here
207 ;
208 ; input
209 ; ECDT = date/time of procedure (required)
210 ; ECPROVS = local array, passed by reference (required)
211 ;
212 ; output
213 ; ECU(1) = provider #1 (mandatory) ien^provider #1 name^person class
214 ; ECU(2) = provider #2 (optional) ien^provider #2 name^person class
215 ; ECU(3) = provider #3 (optional) ien^provider #3 name^person class
216 ;
217 ; returns
218 ; 0 ==> prov selection successful; at least prov #1 selected
219 ; 1 ==> selection unsuccessful or user timed-out
220 ; 2 ==> selection unsuccessful or user entered "^"
221 ;
222 N ECU,ECU2,ECU3,ECDA
223 D GET^ECPRVUTL("",ECDT,.ECU,.ECU2,.ECU3,.ECOUT)
224 S ECPROVS(1)=ECU,ECPROVS(2)=ECU2,ECPROVS(3)=ECU3
225 Q ECOUT
226 ;
227ONEUNIT(ECDSSU) ;- Create ECDSSU containing DSS Unit
228 ; Checks for validity and access to Unit
229 ;
230 ; input
231 ; ECDSSU = passed by reference
232 ;
233 ; output
234 ; ECDDSU = ien in file #724^name of DSS unit OR
235 ; undefined
236 ;
237 ; returns ECOUT = 0 if unit selection sucessful OR
238 ; 1 if user times out; selection unsuccessful
239 ; 2 if user up-arrows out; selection unsuccessful
240 ; Note: if selection is unsuccessful, variable ECDSSU will be undefined.
241 ;
242 N Y,DIRUT,DUOUT,ECKEY,ECOUT
243 S ECKEY=$S($D(^XUSEC("ECALLU",DUZ)):1,1:0)
244 F S ECOUT=0 D Q:$G(ECOUT) Q:$G(ECDSSU)
245 .K DUOUT,DTOUT,DIRUT,Y
246 .W !
247 .S DIC=724,DIC("A")="Select DSS Unit: ",DIC(0)="QEAMZ"
248 .S DIC("S")="I ECKEY!($D(^VA(200,DUZ,""EC"",+Y)))"
249 .D ^DIC K DIC
250 .S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2
251 .Q:$G(ECOUT)
252 .I +Y>0 D Q
253 .. I $$VALID(+Y) S ECDSSU=Y
254 .. I '$$VALID(+Y) D
255 ...S Y=-1
256 ...W !!,?5,"This DSS Unit is either inactive or cannot be used"
257 ...W !,?5,"in Event Capture. Please select a different DSS Unit.",!
258 .I +Y<0 D Q
259 ..W !!,?5,"A response is required...try again."
260 ..W !,?5,"You must enter an ""^"" to exit."
261 .K DIR,DUOUT,DTOUT,DIRUT
262 .W ! S DIR(0)="YA",DIR("A")="Is this correct? ",DIR("B")="YES"
263 .S DIR("?")="Answer YES to accept the unit, NO to start over."
264 .D ^DIR K DIR
265 .I $D(DIRUT) S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2 K ECDSSU Q
266 .I '$G(Y) K ECDSSU
267 Q ECOUT
268 ;
269VALID(IEN) ;- Check DSS Unit for use by Event Capture
270 ;
271 N NODE,NO,YES,VAL
272 S NODE=$G(^ECD(IEN,0))
273 ;piece 6 is 'inactive'; piece 8 is 'use with EC'
274 S NO=$P(NODE,"^",6),YES=$P(NODE,"^",8)
275 ;start out with 'valid'
276 S VAL=1 D
277 .;if 'inactive', then 'not valid'
278 .I NO S VAL=0 Q
279 .;if not 'use with EC', then 'not valid'
280 .I 'YES S VAL=0
281 Q VAL
Note: See TracBrowser for help on using the repository browser.