source: FOIAVistA/trunk/r/QUASAR-ACKQ/ACKQUTL5.m@ 1394

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1ACKQUTL5 ;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.
4SETREF(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
18KILLREF(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 ;
38GETVAL ; 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 ;
48EXCEPT(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
76SEND(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
104MOD ; 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
119MODW ; 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 ;
127MODS ; 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 ;
135CHK(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
148EVNTDIS ; 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
164SETCPT(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
181KILLCPT(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
189ECVOLPRV(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
208CPVOLPRV(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
227KILLEC(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
235EVENT(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 ;
Note: See TracBrowser for help on using the repository browser.