source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQUTL4.m

Last change on this file was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 9.4 KB
Line 
1ACKQUTL4 ;HCIOFO/BH-NEW/EDIT Visit Template Utilities for QUASAR ; 04/01/99
2 ;;3.0;QUASAR;**1,8,14**;Feb 11, 2000;Build 14
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;
5CHK(Y,ACKVD) ;
6 N ACKQQD
7 S ACKQQD=$P(^EC(725,Y,0),"^",3) I ACKQQD="" Q 1
8 I ACKVD<ACKQQD Q 1
9 Q 0
10 ; Clears passed in field # of visit rec.
11CLEAR(ACKVIEN,ACKZNUM) ;
12 N ACKARR
13 S ACKARR(509850.6,ACKVIEN_",",ACKZNUM)=""
14 D FILE^DIE("","ACKARR","")
15 Q
16 ; Decides if patient is/was suffering from MST at the time of the visit
17MST(ACKPCE,ACKVD,ACKPAT) ;
18 I '$$PATCH^XPDUTL("DG*5.3*308") Q 0
19 I ACKPCE'=1 Q 0
20 N ACKRET,ACKXKEEP
21 S ACKXKEEP=X
22 S ACKRET=$$GETSTAT^DGMSTAPI(ACKPAT,ACKVD)
23 S X=ACKXKEEP
24 I $P(ACKRET,"^",2)="Y" Q 1
25 Q 0
26 ;
27PROB(ACKPCE,ACKDIV) ; Decides if Update PCE Problem List prompt appaers
28 I 'ACKPCE Q 0
29 I '$$GET1^DIQ(509850.83,ACKDIV_",1",".09","I") Q 0
30 Q 1
31 ;
32SETUP ; Called from within the New/Edit visit template to set up parameters
33 ;
34 D ENS^%ZISS
35 ;
36 I ACKVISIT="EDIT" D
37 . K ACKAR
38 . S ACKAR(509850.6,ACKVIEN_",",.27)=""
39 . D FILE^DIE("K","ACKAR") K ACKAR
40 ;
41 N ACKX,ACKD0
42 ;
43 S (ICPTVDT,ICDVDT)=ACKVD
44 ;
45 S ACKPCE=$$PCE(ACKDIV,ACKVD) ; Sets PCE indicator
46 ;
47 S ACKEVENT=1
48 S ACKEVENT=$$EVENT^ACKQUTL5(ACKDIV,ACKVD) ; Use EC Codes or CPT
49 ; Indicates whether local clinic #'s are in use
50 S ACKCLNO=$$GET1^DIQ(509850.83,ACKDIV_",1",".04","I")
51 ;
52 ; Indicates whether the bypass flag for Audiometrics is set
53 S ACKBA=$$GET1^DIQ(509850.83,ACKDIV_",1",".07","I")
54 ;
55 ; Indicates whether the visit is service connected
56 S DFN=ACKPAT D ELIG^VADPT S ACKSC=$P(VAEL(3),U,1)
57 ;
58 ; Indicates whether the patient has any previous visits
59 ; with audiometric test scores
60 ;
61 S ACKATS=1
62 S ACKX=$O(^ACK(509850.6,"AMD",ACKPAT,0)),ACKD0=$O(^ACK(509850.6,"AMD",ACKPAT,+ACKX,0))
63 I 'ACKX!('$D(^ACK(509850.6,+ACKD0,0))) S ACKATS=0
64 ;
65 ;
66 S ACKAO=0,ACKRAD=0,ACKENV=0,ACKLOSS="",ACKLAMD=""
67 I ACKPCE D STATUS
68 S:ACKSC ACKQSER=1 S:ACKAO ACKQORG=1
69 S:ACKRAD ACKQIR=1 S:ACKENV ACKQECON=1
70 ;
71 D ELIG
72 ;
73 K VASV,VAEL
74 ;
75 Q
76 ;
77PCE(ACKDIV,ACKVD) ; Sets ACKPCE to 1 if - The send to PCE flag is set
78 ; (for the division) and the PCE INTERFACE START DATE is before or on
79 ; the same day as the Visit Date and the INTERFACE WITH PCE flag for
80 ; the site is set to true.
81 N ACKOUT S ACKOUT=0
82 I $$GET1^DIQ(509850.8,"1,","2","I") D
83 . I $$GET1^DIQ(509850.83,ACKDIV_",1",".03","I"),ACKVD'<$$GET1^DIQ(509850.83,ACKDIV_",1",".08","I") S ACKOUT=1
84 Q ACKOUT
85 ;
86 ;-----
87STATUS ; Sets Agent orange, Radiation and Environmental Contaiment indicators
88 ; if present.
89 ;
90 ; Agent Orange and Radiation
91 D SVC^VADPT S ACKAO=VASV(2),ACKRAD=VASV(3)
92 ;
93 ; Environmental Contaminents
94 S ACKENV=$$GET1^DIQ(2,ACKPAT,.322013,"I")
95 I ACKENV="Y" S ACKENV=1
96 S:ACKENV'="1" ACKENV=0
97 Q
98 ;-----
99 ;
100AUDIO() ; Pass back 1 if user is valid to enter audimetric scores else 0
101 ;
102 I ACKCP=1 Q 1
103 I ACKLOSS,'ACKBA Q 1
104 Q 0
105 ;
106 ;-----
107 ;
108ELIG ; Set up eligibiliy variables and if more than one eligibility create
109 ; display array used in block ELIGDISP
110 ;
111 ; If not service connected set default to primary & file in visit rec.
112 I $P(VAEL(3),U,1)=0 D Q
113 . S ACKELGCT=1,ACKELIG=$P(VAEL(1),U,2),ACKELIG1=$P(VAEL(1),U,1)
114 . K ACKAR S ACKAR(509850.6,ACKVIEN_",",80)=ACKELIG1
115 . D FILE^DIE("K","ACKAR") K ACKAR Q
116 ;
117 S ACKVELG=$$GET1^DIQ(509850.6,ACKVIEN,80,"I") I $G(ACKVELG)'="" D
118 . S ACKVELG=ACKVELG_"^"_$$GET1^DIQ(8,ACKVELG,.01,"I")
119 ;
120 ; Set default eligibility
121 S ACKELIG=$S($G(ACKVELG)'="":$P(ACKVELG,U,2),1:$P(VAEL(1),U,2))
122 ;
123 ; Set up display array
124 ;
125 K ACKELDIS S ACKELGCT=0
126 ;
127 I $G(ACKVELG)'="" S ACKELDIS($P(ACKVELG,U,1))=ACKVELG,ACKELGCT=ACKELGCT+1
128 S ACKELDIS($P(VAEL(1),U,1))=VAEL(1),ACKELGCT=ACKELGCT+1
129 ;
130 S ACKK2=""
131 F S ACKK2=$O(VAEL(1,ACKK2)) Q:ACKK2="" D
132 .S ACKELGCT=ACKELGCT+1
133 .S ACKELDIS($P(VAEL(1,ACKK2),U,1))=VAEL(1,ACKK2)
134 ;
135 ; If not already set up add NSC internal number 5
136 I '$D(ACKELDIS(5)) S ACKELGCT=ACKELGCT+1,ACKELDIS(5)="5^NSC"
137 ;
138 Q
139 ;
140ELIGDIS ; Display patients eligibilities
141 ;
142 N ACKK2,RC
143 D ENS^%ZISS
144 S RC=$$PAGE^ACKQNQ(6) Q:RC<0 W:'RC !!
145 W IOUON,"This Patient has other Entitled Eligibilities",IOUOFF,!!
146 S ACKK2=""
147 F S ACKK2=$O(ACKELDIS(ACKK2)) Q:ACKK2="" D Q:RC<0
148 .Q:$P(ACKELDIS(ACKK2),U,2)=ACKELIG
149 .S RC=$$PAGE^ACKQNQ(2) Q:RC<0
150 .W:RC IOUON,"Other Entitled Eligibilities (cont'd)",IOUOFF,!!
151 .W ?1,$P(ACKELDIS(ACKK2),U,2)_" "
152 .W $$GET1^DIQ(8,ACKK2,5),!
153 Q
154 ;-----
155 ; Display Patient data concerning Rated Disabilities and service clas.
156PATDIS ;
157 S DFN=ACKPAT D RATDIS^ACKQNQ
158 D CLASDIS^ACKQNQ
159 Q
160 ;
161ACKCP() ; This initialises the C&P Paramter.
162 ; First check site parameteres file for C&P flag
163 ;
164 I '$$GET1^DIQ(509850.83,ACKDIV_",1",".06","I") Q 0
165 ;
166 ; Check if C&P has an open request pass back 1 or 0
167 S ACKQCPS=$$EN1^DVBCTRN(ACKPAT,"AUDIO")
168 S:ACKQCPS>0 ACKQCPS=$P(ACKQCPS,U)
169 I $S(ACKCSC'="A":1,$$EN1^DVBCTRN(ACKPAT,"AUDIO",ACKQCPS)<1:1,$O(^ACK(509850.6,"ALCP",ACKQCPS,0))=ACKVIEN:0,$D(^ACK(509850.6,"ALCP",ACKQCPS)):1,1:0) Q 0
170 Q "1^"_ACKQCPS
171 ;
172 ;-----
173PROVDIS ; Get providers already filed and display
174 ;
175 N RC
176 D ENS^%ZISS
177 N ACKK1,ACKPROV,ACKK2,D0,ACKARR,ACKTGT,ACKMSG
178 D LIST^DIC(509850.66,","_ACKVIEN_",",".01","","*","","","","","","ACKTGT","ACKMSG")
179 S ACKK1=""
180 F S ACKK1=$O(ACKTGT("DILIST",1,ACKK1)) Q:ACKK1="" D
181 . S ACKARR(ACKK1)=ACKTGT("DILIST",1,ACKK1)
182 K ACKPROV S ACKK2=ACKVIEN_","
183 D GETS^DIQ(509850.6,ACKK2,"6;7","E","ACKPROV")
184 I '$D(ACKARR),$G(ACKPROV(509850.6,ACKK2,"6","E"))="",$G(ACKPROV(509850.6,ACKK2,"7","E"))="" Q
185 S RC=$$PAGE^ACKQNQ(5) Q:RC<0 W:'RC !!
186 W " ",IOUON,"Providers currently recorded for this visit",IOUOFF,!
187 I $G(ACKPROV(509850.6,ACKK2,"6","E"))'="" W !," Primary Provider - "_ACKPROV(509850.6,ACKK2,"6","E")
188 I $D(ACKARR)>1 S RC=0 D Q:RC<0
189 . S ACKK1=""
190 . F S ACKK1=$O(ACKARR(ACKK1)) Q:ACKK1="" D Q:RC<0
191 . . S RC=$$PAGE^ACKQNQ(2) Q:RC<0
192 . . W !," Secondary Provider - "_ACKARR(ACKK1)
193 D:$G(ACKPROV(509850.6,ACKK2,"7","E"))'=""
194 . S RC=$$PAGE^ACKQNQ(2) Q:RC<0
195 . W !," Student - "_ACKPROV(509850.6,ACKK2,"7","E")
196 W !
197 Q
198 ;
199CPTDIS ; Get procedures already filed and display
200 ;
201 D ENS^%ZISS
202 N D0,ACKKEY,ACKCPTDS,ACKK3,ACKPIEN,ACKTMOD,ACKCODE,ACKPROC,ACKPRV
203 D LIST^DIC(509850.61,","_ACKVIEN_",",".01;.03;.05","I","*","","","","","","ACKCPTDS")
204 I '$D(ACKCPTDS("DILIST",1)) Q
205 W !!," ",IOUON,"Procedures currently entered for this visit",IOUOFF,!
206 S ACKK3=""
207 F S ACKK3=$O(ACKCPTDS("DILIST",1,ACKK3)) Q:ACKK3="" D
208 . S ACKPROC=ACKCPTDS("DILIST",1,ACKK3)
209 . S ACKPRV=ACKCPTDS("DILIST","ID",ACKK3,.05)
210 . I ACKPRV'="" S ACKPRV=$$CONVERT(ACKPRV)
211 . W !," Code: ",$$GET1^DIQ(509850.4,ACKPROC_",",.01),?19,"Volume: ",ACKCPTDS("DILIST","ID",ACKK3,.03) I ACKPRV'="" W " Provider : ",ACKPRV
212 . D LONG^ACKQUTL6(ACKPROC,"1")
213 . W !
214 . ; Check if any Modifiers present for this Procedure
215 . S ACKPIEN="" I $D(ACKCODE(ACKPROC)) S ACKPIEN=$O(ACKCODE(ACKPROC,""),-1)
216 . S ACKPIEN=$O(^ACK(509850.6,ACKVIEN,3,"B",ACKPROC,ACKPIEN))
217 . I ACKPIEN="" W ! Q
218 . S ACKCODE(ACKPROC,ACKPIEN)=""
219 . ; Modifier level present do a LIST to get them
220 . S ACKPIEN=ACKPIEN_","_ACKVIEN
221 . D LIST^DIC(509850.64,","_ACKPIEN_",",".01","I","*","","","","","","ACKTMOD")
222 . I $D(ACKTMOD("DILIST",1)) D
223 . . W " Modifiers:"
224 . . ; Loop through Modifier Array
225 . . S ACKKEY=""
226 . . F S ACKKEY=$O(ACKTMOD("DILIST",1,ACKKEY)) Q:ACKKEY="" D
227 . . . W ?19,$$MODTXT^ACKQUTL8(ACKTMOD("DILIST",1,ACKKEY),ACKVD),!
228 . . K ACKTMOD
229 W !
230 Q
231 ;
232DIAGDIS ; Get diagnoses already filed and display
233 D ENS^%ZISS
234 N ACK1,D0,ACKDIAGD,ACKK3,ACKK4,ACKI,ACKD,RC
235 D LIST^DIC(509850.63,","_ACKVIEN_",",".01;.12","I","*","","","","","","ACKDIAGD")
236 I '$D(ACKDIAGD("DILIST",1)) Q
237 S RC=$$PAGE^ACKQNQ(5) Q:RC<0 W:'RC !!
238 W " ",IOUON,"Diagnoses currently entered for this visit:",IOUOFF,!
239 S ACKK3="",ACKSP=" "
240 F S ACKK3=$O(ACKDIAGD("DILIST",1,ACKK3)) Q:ACKK3="" D
241 . S ACKK4=ACKDIAGD("DILIST",1,ACKK3)
242 . S ACKI=$$GET1^DIQ(80,ACKK4,.01)
243 . S ACKD($S(ACKI?.NP:+ACKI,1:ACKI))=ACKI_$E(" ",1,7-$L(ACKI))_"- "_$E($$DIAGTXT^ACKQUTL8(ACKK4,ACKVD)_ACKSP,1,35)_$S($G(ACKDIAGD("DILIST","ID",ACKK3,".12"))=1:" * Primary Diagnosis *",1:" * Secondary Diagnosis *")
244 ;
245 S ACK1=""
246 F S ACK1=$O(ACKD(ACK1)) Q:ACK1="" D
247 . S RC=$$PAGE^ACKQNQ(3) Q:RC<0
248 . W:RC IOUON,"Diagnoses currently entered for this visit (cont'd)",IOUOFF,!
249 . W !," ",ACKD(ACK1)
250 W !
251 Q
252 ;
253 ;
254HLOSS ; Sets hearing loss variable if one or more diagnosis are for hearing
255 ; loss
256 ;
257 N ACKK4,ACKDIAG
258 S (ACKLOSS,ACKK4)=0
259 F S ACKK4=$O(^ACK(509850.6,ACKVIEN,1,ACKK4)) Q:ACKK4'?1.N!(ACKLOSS) D
260 .S ACKDIAG=$P(^ACK(509850.6,ACKVIEN,1,ACKK4,0),U,1)
261 .I $P(^ACK(509850.1,ACKDIAG,0),U,5)=1 S ACKLOSS=1 Q
262 Q
263 ;
264MODDIS ; Display Modifiers - Called within Executable Help of Modiifer
265 ; Enter Edit.
266 S ACK1="0"
267 F S ACK1=$O(^ACK(509850.5,ACK1)) Q:'+ACK1 D
268 . W !," "_$$GET1^DIQ(81.3,ACK1,.01),?5,$$MODTXT^ACKQUTL8(ACK1,""),?53,$$GET1^DIQ(81.3,ACK1,.04)
269 W ! Q
270 ;
271CONVERT(ACKPRV) ; Converts the QSR Prov Code into a name string from file 200.
272 ;
273 N ACKPRV1,ACKPRV2
274 S ACKPRV1=$P(^ACK(509850.3,ACKPRV,0),U,1)
275 S ACKPRV2=$P(^USR(8930.3,ACKPRV1,0),U,1)
276 Q $$GET1^DIQ(200,ACKPRV2_",",.01)
277 ;
278CONVERT1(ACKPRV) ; Converts the Provider IEN number used within Quasar
279 ; to its equivalent code used on the 200 file.
280 N ACKPRV1
281 S ACKPRV1=$P(^ACK(509850.3,ACKPRV,0),U,1)
282 Q $P(^USR(8930.3,ACKPRV1,0),U,1)
283 ;
284CONVERT2(ACKPRV) ; Converts the Provider IEN number used within Quasar
285 ; to its equivalent code used on the 200 file.
286 N ACKPRV1
287 S ACKPRV1=$P(^ACK(509850.3,ACKPRV,0),U,1)
288 Q $P($G(^USR(8930.3,ACKPRV1,0)),U,1)
Note: See TracBrowser for help on using the repository browser.