1 | ACKQUTL5 ;HCIOFO/BH-Quasar utilities routine ; 04/01/99
|
---|
2 | ;;3.0;QUASAR;**1,4,6,8**;Feb 11, 2000
|
---|
3 | ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
|
---|
4 | SETREF(X,ACKVIEN,ACKTYPE) ;
|
---|
5 | ; Maintains APCE xRef When 3 of the 4 entries are present & the 4TH
|
---|
6 | ; has been entered a new entry will be set up. If any of the 4 data
|
---|
7 | ; items used within the X ref are changed the entry will be deleted & a
|
---|
8 | ; new 1 set up
|
---|
9 | N ACKTME,ACKCLIN,ACKVD,ACKPAT
|
---|
10 | D GETVAL
|
---|
11 | I ACKTME="",ACKTYPE'="T" Q
|
---|
12 | I ACKCLIN="",ACKTYPE'="C" Q
|
---|
13 | I ACKVD="",ACKTYPE'="D" Q
|
---|
14 | I ACKPAT="",ACKTYPE'="P" Q
|
---|
15 | ;
|
---|
16 | S ^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,ACKTME,ACKVIEN)=""
|
---|
17 | Q
|
---|
18 | KILLREF(X,ACKVIEN,ACKTYPE) ;
|
---|
19 | ; When any of the 4 var values that make up the APCE xRef are deleted
|
---|
20 | ; or when the visit record is deleted the APCE xRef will be deleted
|
---|
21 | N ACKTME,ACKCLIN,ACKVD,ACKPAT
|
---|
22 | D GETVAL
|
---|
23 | ;
|
---|
24 | I ACKTYPE'="T",ACKTME="" Q ; If any of the 4 field values other than
|
---|
25 | I ACKTYPE'="C",ACKCLIN="" Q ; the field being edited are null the
|
---|
26 | I ACKTYPE'="D",ACKVD="" Q ; xRef will not have been set up
|
---|
27 | I ACKTYPE'="P",ACKPAT="" Q
|
---|
28 | ;
|
---|
29 | I ACKTYPE="D" S ACKVD=X ; X=Old field value
|
---|
30 | I ACKTYPE="P" S ACKPAT=X
|
---|
31 | I ACKTYPE="C" S ACKCLIN=X
|
---|
32 | I ACKTYPE="T" S ACKTME=X
|
---|
33 | ;
|
---|
34 | I $D(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,ACKTME,ACKVIEN)) D
|
---|
35 | . K ^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,ACKTME,ACKVIEN)
|
---|
36 | Q
|
---|
37 | ;
|
---|
38 | GETVAL ; Used with SETREF & KILLREF - Gets The Clinic, Visit Date, Visit
|
---|
39 | ; time and Patient from the visit file currently being processed
|
---|
40 | N ACKTGT
|
---|
41 | D GETS^DIQ(509850.6,ACKVIEN_",",".01;1;2.6;55","I","ACKTGT")
|
---|
42 | S ACKVD=$G(ACKTGT(509850.6,ACKVIEN_",",.01,"I"))
|
---|
43 | S ACKPAT=$G(ACKTGT(509850.6,ACKVIEN_",",1,"I"))
|
---|
44 | S ACKCLIN=$G(ACKTGT(509850.6,ACKVIEN_",",2.6,"I"))
|
---|
45 | S ACKTME=$G(ACKTGT(509850.6,ACKVIEN_",",55,"I"))
|
---|
46 | Q
|
---|
47 | ;
|
---|
48 | EXCEPT(ACKVIEN,ACKFLD,ACKVAL) ; Called from xRefs within the LAST SENT TO PCE, LAST
|
---|
49 | ; EDITED IN QSR and PCE VISIT IEN fields
|
---|
50 | N ACKTGT,ACKPIEN,ACKSENT,ACKEDIT,ACKARR,ACKEXCP
|
---|
51 | I ACKFLD=125 D
|
---|
52 | . S ACKPIEN=ACKVAL
|
---|
53 | . S ACKSENT=$$GET1^DIQ(509850.6,ACKVIEN_",",135,"I")
|
---|
54 | . S ACKEDIT=$$GET1^DIQ(509850.6,ACKVIEN_",",140,"I")
|
---|
55 | I ACKFLD=135 D
|
---|
56 | . S ACKPIEN=$$GET1^DIQ(509850.6,ACKVIEN_",",125,"I")
|
---|
57 | . S ACKSENT=ACKVAL
|
---|
58 | . S ACKEDIT=$$GET1^DIQ(509850.6,ACKVIEN_",",140,"I")
|
---|
59 | I ACKFLD=140 D
|
---|
60 | . S ACKPIEN=$$GET1^DIQ(509850.6,ACKVIEN_",",125,"I")
|
---|
61 | . S ACKSENT=$$GET1^DIQ(509850.6,ACKVIEN_",",135,"I")
|
---|
62 | . S ACKEDIT=ACKVAL
|
---|
63 | ;
|
---|
64 | ; if PCE visit ien known and PCE updated last then no exception
|
---|
65 | I ACKPIEN'="",ACKEDIT'="",ACKSENT'="",ACKEDIT<ACKSENT D Q
|
---|
66 | . S ACKARR(509850.6,ACKVIEN_",",900)="@"
|
---|
67 | . D FILE^DIE("","ACKARR")
|
---|
68 | ; else this visit is an exception - only update if null or
|
---|
69 | ; earlier than today
|
---|
70 | S ACKEXCP=$$GET1^DIQ(509850.6,ACKVIEN_",",900,"I")
|
---|
71 | D NOW^%DTC
|
---|
72 | I (ACKEXCP="")!(ACKEXCP\1<(%\1)) D
|
---|
73 | . S ACKARR(509850.6,ACKVIEN_",",900)=%
|
---|
74 | . D FILE^DIE("","ACKARR")
|
---|
75 | Q
|
---|
76 | SEND(ACKVIEN) ; Called when entering/editing any of the PCE fields.
|
---|
77 | ; inputs: ACKVIEN - visit ien
|
---|
78 | ; this s/r is used in the xRef of any data field that, if changed,
|
---|
79 | ; should be sent to PCE to keep PCE up to date. The edit triggers the
|
---|
80 | ; xRef call to this s/r. It ensures that the LAST EDITED IN QSR date is
|
---|
81 | ; after the LAST SENT TO PCE date so that the visit becomes a PCE
|
---|
82 | ; EXCEPTION. NB. The LAST EDITED IN QSR date will only be updated if
|
---|
83 | ; a. it is currently earlier than the LAST SENT TO PCE and by updating
|
---|
84 | ; it the visit becomes a PCE Exception. or b. the current value is
|
---|
85 | ; earlier than today this saves the system from constantly updating
|
---|
86 | ; this field and checking the exception status each time a pce field
|
---|
87 | ; is changed
|
---|
88 | N ACKARR,ACKEDIT,ACKSENT
|
---|
89 | ; get current value of LAST EDITED IN QSR and LAST SENT TO PCE
|
---|
90 | S ACKEDIT=$$GET1^DIQ(509850.6,ACKVIEN_",",140,"I")
|
---|
91 | S ACKSENT=$$GET1^DIQ(509850.6,ACKVIEN_",",135,"I")
|
---|
92 | D NOW^%DTC
|
---|
93 | ; if qsr edit currently earlier than sent to pce update
|
---|
94 | I ACKEDIT<ACKSENT D Q
|
---|
95 | . S ACKARR(509850.6,ACKVIEN_",",140)=%
|
---|
96 | . D FILE^DIE("","ACKARR")
|
---|
97 | ;
|
---|
98 | ; if last edit is earlier than today update
|
---|
99 | I (ACKEDIT\1)<(%\1) D Q
|
---|
100 | . S ACKARR(509850.6,ACKVIEN_",",140)=%
|
---|
101 | . D FILE^DIE("","ACKARR")
|
---|
102 | ; nothing to do - QSR date must already be after LAST SENT and for today
|
---|
103 | Q
|
---|
104 | MOD ; Creates an array of valid CPT Modfrs. gets all valid Mods for the
|
---|
105 | ; Proc then disgards any that are not on the A&SP Proc Mod file or that
|
---|
106 | ; are on file but Inactive
|
---|
107 | K ACKMOD,ACKMODD
|
---|
108 | N CDT,ACKMOD1,ACKM1,ACKK2
|
---|
109 | I $$PATCH^XPDUTL("PX*1.0*73") S ACKMOD1=$$CODM^ICPTCOD(ACKPC,"ACKMODD","",ACKVD)
|
---|
110 | I '$$PATCH^XPDUTL("PX*1.0*73") S ACKMOD1=$$CODM^ICPTCOD(ACKPC,"ACKMODD")
|
---|
111 | S ACKM1=""
|
---|
112 | F S ACKM1=$O(ACKMODD(ACKM1)) Q:ACKM1="" D
|
---|
113 | . S ACKK2=$P(ACKMODD(ACKM1),U,2)
|
---|
114 | . I '$D(^ACK(509850.5,ACKK2,0)) K ACKMODD(ACKM1) Q
|
---|
115 | . I $P(^ACK(509850.5,ACKK2,0),U,2)=0 K ACKMODD(ACKM1) Q
|
---|
116 | . K ACKMODD(ACKM1) S ACKMOD(ACKPC,ACKK2)=""
|
---|
117 | S ACKMOD(ACKPC)=""
|
---|
118 | Q
|
---|
119 | MODW ; Called from x ref of Modfr field within 509850.6
|
---|
120 | I X'["?" Q
|
---|
121 | N ACKQDDD
|
---|
122 | S ACKQDDD=$G(ACKVD)
|
---|
123 | S DIC("W")="W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_"),?48,$$GET1^DIQ(81.3,Y,.04)"
|
---|
124 | Q
|
---|
125 | ;
|
---|
126 | ;
|
---|
127 | MODS ; Screen for Modfrs input within Modifrs field of Modfrs File
|
---|
128 | N ACKQDDD
|
---|
129 | S ACKQDDD=$G(ACKVD)
|
---|
130 | S DIC("S")="D GETS^DIQ(81.3,Y,"".04;5"",""I"",""ACKARR"",""ACKMSG"") I ACKARR(81.3,Y_"","",.04,""I"")=""C""!(ACKARR(81.3,Y_"","",.04,""I"")=""H""),ACKARR(81.3,Y_"","",5,""I"")'=1"
|
---|
131 | S DIC("W")="W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_")"
|
---|
132 | Q
|
---|
133 | ;
|
---|
134 | ;
|
---|
135 | CHK(Y,ACKVD,ACKCSC) ; Screen for EC codes
|
---|
136 | N ACKQCD,ACKQQD,ACKQQCPT,ACKPARAM
|
---|
137 | I $E($P(^EC(725,+Y,0),"^",2),1,2)'="SP" Q 0
|
---|
138 | S ACKQQCPT=$$GET1^DIQ(725,+Y_",",4,"I") I ACKQQCPT="" Q 0
|
---|
139 | ;S ACKQCD=$$CONVERT(ACKQQCPT) I ACKQCD="" Q 0
|
---|
140 | S ACKQCD=ACKQQCPT
|
---|
141 | S ACKPARAM=$P($$CPT^ICPTCOD(ACKQCD,ACKVD),"^",7) I 'ACKPARAM Q 0
|
---|
142 | I '$D(^ACK(509850.4,ACKQCD,0)) Q 0
|
---|
143 | I $P(^ACK(509850.4,ACKQCD,0),U,2)'[$E(ACKCSC) Q 0
|
---|
144 | I $P(^ACK(509850.4,ACKQCD,0),U,4)'=1 Q 0
|
---|
145 | S ACKQQD=$P(^EC(725,Y,0),"^",3) I ACKQQD="" Q 1
|
---|
146 | I ACKVD<ACKQQD Q 1
|
---|
147 | Q 0
|
---|
148 | EVNTDIS ; Get EC Procs filed and display
|
---|
149 | D ENS^%ZISS
|
---|
150 | N D0,ACKKEY,ACKEVTDS,ACKK3,ACKPROC,ACKPRV,ACKNME,ACKNATNM
|
---|
151 | D LIST^DIC(509850.615,","_ACKVIEN_",",".01;.03;.05","I","*","","","","","","ACKEVTDS")
|
---|
152 | I '$D(ACKEVTDS("DILIST",1)) Q
|
---|
153 | W !!," ",IOUON,"Event Capture Procedures currently entered for this visit",IOUOFF,!
|
---|
154 | S ACKK3=""
|
---|
155 | F S ACKK3=$O(ACKEVTDS("DILIST",1,ACKK3)) Q:ACKK3="" D
|
---|
156 | . S ACKPROC=ACKEVTDS("DILIST",1,ACKK3)
|
---|
157 | . S ACKPRV=ACKEVTDS("DILIST","ID",ACKK3,.05)
|
---|
158 | . I ACKPRV'="" S ACKPRV=$$CONVERT^ACKQUTL4(ACKPRV)
|
---|
159 | . S ACKNME=$$GET1^DIQ(725,ACKPROC_",",.01) S ACKNME=$E(ACKNME,1,29)
|
---|
160 | . S ACKNATNM=$$GET1^DIQ(725,ACKPROC_",",1)
|
---|
161 | . W !," Nat.#: ",ACKNATNM,?14," Name: ",ACKNME,?55,"Vol.: ",ACKEVTDS("DILIST","ID",ACKK3,.03) I ACKPRV'="" W !,?14,"Provider: ",ACKPRV
|
---|
162 | . W !
|
---|
163 | Q
|
---|
164 | SETCPT(DA,ACKQQIEN,X) ; When EC Code is entered create a CPT entry
|
---|
165 | I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
|
---|
166 | N ACK,ACKARR1,ACKCIEN,ACKQQCPT
|
---|
167 | ; Get CPT associated with EC code
|
---|
168 | S ACKQQCPT=$$GET1^DIQ(725,X_",",4,"I")
|
---|
169 | ;S ACKQQCPT=$$CONVERT(ACKQQCPT)
|
---|
170 | S ACKCIEN="" K ACKARR1
|
---|
171 | ; Create CPT entry and enter DA as CPT's pter to creating EC entry
|
---|
172 | S ACKARR1(509850.61,"+1,"_ACKQQIEN_",",.01)=ACKQQCPT
|
---|
173 | S ACKARR1(509850.61,"+1,"_ACKQQIEN_",",.07)=DA
|
---|
174 | D UPDATE^DIE("","ACKARR1","ACKCIEN","")
|
---|
175 | K ACK
|
---|
176 | ; After CPT entry set up get its IEN & set it to the creating EC
|
---|
177 | ; entries CPT ptr field
|
---|
178 | S ACK(509850.615,DA_","_ACKQQIEN_",",.07)=ACKCIEN(1)
|
---|
179 | D FILE^DIE("","ACK","")
|
---|
180 | Q
|
---|
181 | KILLCPT(DA,ACKQQIEN) ; Deletes CPT entry if created by an EC entry
|
---|
182 | I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
|
---|
183 | Q:'ACKEVENT ; Q if Div set up to use CPT's
|
---|
184 | N ACKCIEN,ACK
|
---|
185 | S ACKCIEN=$$GET1^DIQ(509850.615,DA_","_ACKQQIEN_",",.07)
|
---|
186 | I ACKCIEN="" Q
|
---|
187 | S ACK(509850.61,ACKCIEN_","_ACKQQIEN_",",.01)="@" D FILE^DIE("","ACK")
|
---|
188 | Q
|
---|
189 | ECVOLPRV(DA,ACKQQIEN,X,ACKQQVP,ACKQQDS) ; Update CPT rec. when EC data entered
|
---|
190 | ;If CPT entry linked with the EC entry -
|
---|
191 | ; If ACKQQDS='S'
|
---|
192 | ; If ACKQQVP='V' set EC vol to CPT vol
|
---|
193 | ; If ACKQQVP='P' set EC Prvdr to CPT Prvdr
|
---|
194 | ; If ACKQQDS='D'
|
---|
195 | ; If ACKQQVP='V' delete CPT vol
|
---|
196 | ; If ACKQQVP='P' delete CPT Prvdr
|
---|
197 | ;
|
---|
198 | I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
|
---|
199 | Q:'ACKEVENT
|
---|
200 | N ACKFIELD,ACKVAL,ACK,ACKCIEN
|
---|
201 | S ACKCIEN=$$GET1^DIQ(509850.615,DA_","_ACKQQIEN_",",.07)
|
---|
202 | I ACKCIEN="" Q
|
---|
203 | S ACKFIELD=".03" I ACKQQVP="P" S ACKFIELD=".05"
|
---|
204 | S ACKVAL=X I ACKQQDS="D" S ACKVAL="@"
|
---|
205 | S ACK(509850.61,ACKCIEN_","_ACKQQIEN_",",ACKFIELD)=ACKVAL
|
---|
206 | D FILE^DIE("","ACK","")
|
---|
207 | Q
|
---|
208 | CPVOLPRV(DA,ACKQQIEN,X,ACKQQVP,ACKQQDS) ; Update EC rec. when CPT data entered
|
---|
209 | ;If EC entry linked with the CPT entry -
|
---|
210 | ; If ACKQQDS='S'
|
---|
211 | ; If ACKQQVP='V' set CPT vol to EC vol
|
---|
212 | ; If ACKQQVP='P' set CPT Prvdr to EC Prvdr
|
---|
213 | ; If ACKQQDS='D'
|
---|
214 | ; If ACKQQVP='V' delete EC vol
|
---|
215 | ; If ACKQQVP='P' delete EC Prvdr
|
---|
216 | ;
|
---|
217 | I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
|
---|
218 | Q:ACKEVENT
|
---|
219 | N ACKFIELD,ACKVAL,ACK,ACKEIEN
|
---|
220 | S ACKEIEN=$$GET1^DIQ(509850.61,DA_","_ACKQQIEN_",",.07)
|
---|
221 | I ACKEIEN="" Q
|
---|
222 | S ACKFIELD=".03" I ACKQQVP="P" S ACKFIELD=".05"
|
---|
223 | S ACKVAL=X I ACKQQDS="D" S ACKVAL="@"
|
---|
224 | S ACK(509850.615,ACKEIEN_","_ACKQQIEN_",",ACKFIELD)=ACKVAL
|
---|
225 | D FILE^DIE("","ACK","")
|
---|
226 | Q
|
---|
227 | KILLEC(DA,ACKQQIEN) ; Delets EC entry if CPT entry has EC pter
|
---|
228 | I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
|
---|
229 | Q:ACKEVENT ; Q if Div set up to use EC's
|
---|
230 | N ACKECIEN,ACK
|
---|
231 | S ACKECIEN=$$GET1^DIQ(509850.61,DA_","_ACKQQIEN_",",.07)
|
---|
232 | I ACKECIEN="" Q
|
---|
233 | S ACK(509850.615,ACKECIEN_","_ACKQQIEN_",",.01)="@" D FILE^DIE("","ACK")
|
---|
234 | Q
|
---|
235 | EVENT(ACKDIV,ACKVD) ; params set up for Divn to use EC Codes ?
|
---|
236 | N ACKY,X,Y,ACKM
|
---|
237 | S ACKY=$E(ACKVD,2,3),ACKM=$E(ACKVD,4,5)
|
---|
238 | I ACKM>9 S ACKY=ACKY+1 I $L(ACKY)=1 S ACKY="0"_ACKY
|
---|
239 | I '$D(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY)) Q 0
|
---|
240 | S ACKKEY=0
|
---|
241 | S ACKKEY=$O(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY,ACKKEY))
|
---|
242 | S ACKEC=$P(^ACK(509850.8,1,2,ACKDIV,2,ACKKEY,0),"^",2)
|
---|
243 | I ACKEC="" S ACKEC="0"
|
---|
244 | Q ACKEC
|
---|
245 | ;
|
---|