source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRVRPOC.m@ 1053

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1LRVRPOC ;DALOI/JMC - POINT OF CARE VERIFICATION ; 4 May 2004
2 ;;5.2;LAB SERVICE;**290**;Sep 27, 1994
3 ;
4 ; Reference to DIVSET^XUSRB2 supported by DBIA #4055
5 ; Reference to ADM^VADPT2 supported by DBIA #325
6 ;
7EN ; Entry Point Call with LRLL=Load/Worklist IEN
8 ;
9 N DIQUIET
10 ;
11 S LRLL=+$G(LRLL)
12 ;
13 ; See if already running
14 L +^LAH("Z",LRLL):10
15 E D END Q
16 ;
17 I '$D(^LRO(68.2,LRLL,0))#2 D END Q
18 S LRLL(0)=^LRO(68.2,LRLL,0)
19 ;
20 ; Must be POC Load/Work List
21 I $$GET1^DIQ(68.2,LRLL,.03,"I")'=2 D Q
22 . S LAMSG="POC: Unable to process POC results using non-POC worklist "_$$GET1^DIQ(68.2,LRLL,.01)
23 . D XQA^LA7UXQA(2,0,0,0,LAMSG,"")
24 . D END
25 ;
26 ;
27 ; If rollover has not completed
28 ; then requeue task 1 hour in future and send alert.
29 I $G(^LAB(69.9,1,"RO"))'=+$H D Q
30 . S ZTREQ=$$HADD^XLFDT($H,0,1,0,0)
31 . S LAMSG="POC: Lab Rollover has not completed as of "_$$HTE^XLFDT($H,"1M")
32 . D XQA^LA7UXQA(2,0,0,0,LAMSG,"")
33 . D END
34 ;
35 D INIT^LRVRPOCU
36 I LREND D Q
37 . D XQA^LA7UXQA(2,0,0,0,"POC: "_LAMSG,"")
38 . D END
39 ;
40 S LAIEN=0
41 F S LAIEN=$O(^LAH(LRLL,1,LAIEN)) Q:LAIEN<1 D
42 . I $$S^%ZTLOAD S ZTSTOP=1 Q ; Task has been requested to stop
43 . K LRERR
44 . S LASSN=$P($G(^LAH(LRLL,1,LAIEN,.1,"PID","SSN")),"^")
45 . ; Interface message number in ^LAHM(62.49
46 . S LA76249=+$P($G(^LAH(LRLL,1,LAIEN,0)),U,13)
47 . ; File #62.48 configuration link
48 . S LA76248=""
49 . I LA76249 S LA76248=$$GET1^DIQ(62.49,LA76249_",",.5,"I")
50 . D LOOK,NEXT,ZAPALL^LRVR3(LRLL,LAIEN)
51 D END
52 Q
53 ;
54 ;
55NEXT ; Clean up between entries
56 D CLEAN^LRVRPOCU
57 Q
58 ;
59 ;
60END ; Clean up and quit
61 ; Release lock
62 L -^LAH("Z",LRLL)
63 ;
64 D SPALERT^LRVRPOCU,KVAR^VADPT,KILL^XUSCLEAN
65 K ^TMP("LR",$J)
66 I $D(ZTQUEUED),'$P($G(ZTREQ),"^") S ZTREQ="@"
67 Q
68 ;
69 ;
70LOOK ; Check for data
71 K LRDFN,LRERR
72 S LRODT=DT,(LREND,LRERR)=0
73 S DFN=$$FIND1^DIC(2,"","X",LASSN,"SSN","","")
74 I 'DFN D Q
75 . S LRERR=$$CREATE^LA7LOG(101,1)
76 . D SENDACK^LRVRPOCU
77 S LADFN=DFN
78 I '$D(^LAH(LRLL,1,LAIEN,0))#2 D Q
79 . S LRERR=$$CREATE^LA7LOG(105,1)
80 . D SENDACK^LRVRPOCU
81 S LRCDT=$P($G(^LAH(LRLL,1,LAIEN,.1,"OBR","ORCDT")),"^")
82 I LRCDT'?7N.E D Q
83 . S LRERR=$$CREATE^LA7LOG(104,1)
84 . D SENDACK^LRVRPOCU
85 S LRDFN=$$FNLRDFN(LADFN)
86 I $S(LREND:1,LRDFN<1:1,1:0) Q
87 S LRSSN=$S($G(^LAH(LRLL,1,LAIEN,.1,"PID","SSN")):^("SSN"),1:"???")
88 I LRSSN'=$G(SSN(2)) D Q
89 . S LRERR=$$CREATE^LA7LOG(106,1)
90 . D SENDACK^LRVRPOCU
91 S LRTJ=""
92 D DATA(LRLL,LAIEN)
93 Q
94 ;
95 ;
96FNLRDFN(DFN) ;Lookup/set LRDFN and define patient variables
97 D KVAR^VADPT
98 K ANS,ERR,LRDPF,PNM,X
99 I $S(+DFN'=DFN:1,'$G(DFN):1,'$D(^DPT(DFN,0))#2:1,1:0) D Q 0
100 . S LREND=1,LRERR=$$CREATE^LA7LOG(108,1)
101 . D SENDACK^LRVRPOCU
102 S LRDFN=$$GET1^DIQ(2,DFN_",",63,"I","ANS","ERR")
103 S PNM="Unknown"
104 I LRDFN<1 S LRDFN=$$NEWPT(DFN)
105 I LRDFN>0 D Q LRDFN
106 . D DEM^LRX
107 . I $G(LREND) S LRDFN=0 Q
108 . S VAINDT=LRCDT D ADM^VADPT2
109 . S VAIP("D")=$S(VADMVT:LRCDT,1:LRCDT\1) D IN5PT^LRX
110 . D DPT(SSN(2))
111 . I LRERR S LREND=1,LRDFN=0
112 Q 0
113 ;
114 ;
115NEWPT(DFN) ;Set ^LR( root for patient
116 S LRDPF="2^DPT(",X="^"_$P(LRDPF,"^",2)_DFN_",""LR"")"
117 S LRDFN=$O(^LR("A"),-1) I 'LRDFN S LRDFN=1
118 L +^LR(0):99
119 D E2^LRDPA
120 L -^LR(0)
121 I $G(LRDFN)<1 S LREND=1,LRDFN=0
122 Q LRDFN
123 ;
124 ;
125DPT(LRASSN) ;
126 N LRX,X,Y,DIC
127 S (LRERR,LRDFN)=""
128 S DFN=$$FIND1^DIC(2,"","X",LRASSN,"SSN","","")
129 I 'DFN D Q
130 . N LASSN
131 . S LASSN=LRASSN,LRERR=$$CREATE^LA7LOG(101,1)
132 . D SENDACK^LRVRPOCU
133 S LRDFN=$$GET1^DIQ(2,DFN_",",63,"I","ANS","ERR")
134 I 'LRDFN D END^LRDPA Q:'$G(LRDFN)
135 S LRX=$G(^LAH(LRLL,1,LAIEN,.1,"PID","LRDFN"))
136 I LRX,LRX'=LRDFN D Q
137 . S LRERR=$$CREATE^LA7LOG(103,1)
138 . D SENDACK^LRVRPOCU
139 ;
140 S LRX=$G(^LAH(LRLL,1,LAIEN,.1,"PID","DFN"))
141 I LRX,LRX'=DFN D Q
142 . S LRERR=$$CREATE^LA7LOG(102,1)
143 . D SENDACK^LRVRPOCU
144 ;
145 ; Determine ordering provider
146 N LRX,LRY,X,Y
147 S LRPRAC=""
148 S LRX=$G(^LAH(LRLL,1,LAIEN,.1,"OBR","ORDP"))
149 I '$P(LRX,"^",2),$P(LRX,"^")'="" D Q:LRERR
150 . S LRERR=$$CREATE^LA7LOG(119,1)
151 . D SENDACK^LRVRPOCU
152 ; Check if a valid provider
153 I $P(LRX,"^",2) D Q:LRERR
154 . I $$PROVIDER^XUSER(+LRX) S LRPRAC=+LRX Q
155 . S LRERR=$$CREATE^LA7LOG(119,1)
156 . D SENDACK^LRVRPOCU
157 ;
158 ; If no ordering provider in message then check for inpatient provider.
159 I 'LRPRAC D
160 . I $G(VAIP(7)) S LRPRAC=+VAIP(7) Q
161 . I $G(VAIP(18)) S LRPRAC=+VAIP(18) Q
162 ;
163 ; Use VADPT for inpatients - clinic enrollment for outpatient
164 ; Check if ordering location/division from message
165 S X=$G(^LAH(LRLL,1,LAIEN,.1,"OBR","EOL"))
166 S LROLLOC=+X,LROLDIV=$P(X,"^",3)
167 ;
168 ; Check for inpatient location if no location
169 I 'LROLLOC,$G(VAIP(5)) D
170 . S LROLLOC=$$GET1^DIQ(42,+VAIP(5)_",",44,"I")
171 . I 'LROLDIV S LROLDIV=$$GET1^DIQ(44,LROLLOC_",",3,"I")
172 ;
173 ; Check for outpatient appointments if no location
174 I 'LROLLOC!('LRPRAC) D VASD^LRVRPOCU
175 ;
176 ; If no location then log error.
177 I 'LROLLOC D Q
178 . S LRERR=$$CREATE^LA7LOG(107,1)
179 . D SENDACK^LRVRPOCU
180 ;
181 ; If no in/outpatient provider then check for primary care provider
182 I 'LRPRAC S LRPRAC=+$$OUTPTPR^SDUTL3(DFN,LRCDT)
183 ;
184 ; If no provider - none in message, no primary care and no provider on
185 ; outpatient encounter then log error.
186 I 'LRPRAC D Q
187 . S LRERR=$$CREATE^LA7LOG(110,1)
188 . D SENDACK^LRVRPOCU
189 ;
190 ; If division in message does not match location's division then reject.
191 ; Check if division not a VAMC and parent is a VAMC and division
192 ; matches parent - deal with multiple medical centers within an
193 ; integrated system.
194 I LROLDIV D Q:LRERR
195 . N DIV,OK,LRX
196 . S DIV=$$GET1^DIQ(44,LROLLOC_",",3,"I")
197 . I LROLDIV=DIV Q
198 . S X=$$NNT^XUAF4(DIV),OK=0
199 . I $P(X,"^",3)'="VAMC" D Q:OK
200 . . S Y=$P($$PRNT^XUAF4($P(X,"^")),"^"),X=$$NNT^XUAF4(Y)
201 . . I $P(X,"^",3)="VAMC",$P(Y,"^")=LROLDIV S OK=1
202 . S LRX=$$NNT^XUAF4(LROLDIV)
203 . S LRERR=$$CREATE^LA7LOG(112,1)
204 . D SENDACK^LRVRPOCU
205 ;
206 ; Get location abbreviation
207 S LRLLOC=$$GET1^DIQ(44,LROLLOC_",",1,"I")
208 I LRLLOC="" S LRLLOC="NO ABRV "_LROLLOC
209 Q
210 ;
211 ;
212DATA(LRLL,LAIEN) ;Extract results into LROT(
213 ;
214 K LR642,LRDATA,LRERR,LRSPECX,LRCNT,LROSPEC,LROT,LRSAMP,LRSB,LRSPEC,LRTRAY,LRCUP,LRSQ,LRTS,LRX,LRY,LRZ
215 S LRSQ=LAIEN,LRDATA=1,(LR642,LRCNT,LRERR)=0,(LRDAA,LRSAMP,LRSPEC)=""
216 S LRLL(0)=^LRO(68.2,LRLL,0)
217 S LROSPEC=$P($G(^LAH(LRLL,1,LAIEN,.1,"OBR","ORDSPEC")),"^")
218 I LROSPEC="" D Q
219 . S LRERR=$$CREATE^LA7LOG(114,1)
220 . D SENDACK^LRVRPOCU
221 S LRX=$G(^LAH(LRLL,1,LAIEN,.1,"OBR","ORDNLT"))
222 ;
223 ; Change division to ordering division
224 S LRDUZ(2)=$S(LROLDIV:LROLDIV,1:LRDIV)
225 I LRDUZ(2)'=DUZ(2) D Q:LRERR
226 . N LA7X,LRY
227 . S LRY=0
228 . D DIVSET^XUSRB2(.LRY,"`"_LRDUZ(2))
229 . I LRY Q
230 . S LA7X="Unable to set user 'LRLAB,POC' to division "_$$GET1^DIQ(4,LRDUZ(2)_",",.01)
231 . S LRERR=$$CREATE^LA7LOG(37,1)
232 ;
233 ; Ordering based on NLT codes from loadlist profile and OBR segment
234 F I=1:1:$L(LRX,"^") S LRY=$P(LRX,"^",I) Q:LRY="" D Q:LRERR
235 . I '$D(LRORDNLT(LRY,LROSPEC)) S LRERR=$$CREATE^LA7LOG(120,1) Q
236 . S LRZ=LRORDNLT(LRY,LROSPEC)
237 . S LRTST=$P(LRZ,"^"),LRSPEC=$P(LRZ,"^",2),LRSAMP=$P(LRZ,"^",3)
238 . I '$D(^TMP("LR",$J,"VTO",LRTST)) S LRERR=$$CREATE^LA7LOG(118,1) Q
239 . I 'LRSPEC S LRERR=$$CREATE^LA7LOG(114,1) Q
240 . I 'LRSAMP S LRERR=$$CREATE^LA7LOG(115,1) Q
241 . S LRCNT=LRCNT+1,LROT(LRSAMP,LRSPEC,LRCNT)=LRTST
242 . I $P(LRZ,"^",4) S LR642=$P(LRZ,"^",4)
243 . I 'LRDAA,LROLDIV,$D(^LAB(60,LRTST,8,LROLDIV,0)) S LRDAA=$P(^(0),U,2)
244 I LRERR D SENDACK^LRVRPOCU Q
245 I LRDAA<1 S LRDAA=$P(^LRO(68.2,LRLL,10,LRPROF,0),"^",2)
246 ;
247 ; Check for results to process
248 I '$O(LROT(0)) D Q
249 . S LRERR=$$CREATE^LA7LOG(113,1)
250 . D SENDACK^LRVRPOCU
251 ;
252 ; Setup workload suffix
253 I LR642<1 S LR642=LRDFWKLD
254 D WKLD^LRVRPOCU(LR642)
255 ;
256 ; Check if results have datanames/tests on this profile.
257 F S LRDATA=$O(^LAH(LRLL,1,LAIEN,LRDATA)) Q:LRDATA<1 D Q:LRERR
258 . I $P($G(^LAH(LRLL,1,LAIEN,LRDATA)),U)="" Q
259 . S LRDATA(LRDATA)=^LAH(LRLL,1,LAIEN,LRDATA)
260 . I $P(LRDATA(LRDATA),"^",4)<1 S LRERR=$$CREATE^LA7LOG(111,1) Q
261 . S LRTST=+$G(LRVTS(LRDATA))
262 . I 'LRTST S LRERR=$$CREATE^LA7LOG(116,1) Q
263 . I '$D(^TMP("LR",$J,"VTO",LRTST)) S LRERR=$$CREATE^LA7LOG(118,1) Q
264 I LRERR D SENDACK^LRVRPOCU Q
265 ;
266 K LRCOM
267 S LRNT=$$NOW^XLFDT,LRORDTIM=""
268 ;
269 ; Setup the order in LRO(69
270 S LRNOLABL="" ; Suppress label printing
271 D
272 . N LRSPEC,LRSAMP,ZTQUEUED
273 . S ZTQUEUED=1
274 . D ORDER^LROW2,^LRORDST
275 ;
276 ; Setup LRO(68
277 D
278 . N LRSPEC,LRSAMP
279 . D ^LRWLST
280 I '$G(LRAA) D Q
281 . S LRERR=$$CREATE^LA7LOG(109,1)
282 . D SENDACK^LRVRPOCU
283 ;
284 S LRMETH="POC DEVICE"
285 I LA76248 S LRMETH=$E($$GET1^DIQ(62.48,LA76248_",",.01),1,10)
286 I LRMETH="" S LRMETH=$E($P(LRLL(0),U),1,5)_"(POC)"
287 ;
288 ; Store POC specimen id in file #63 as ordering site UID.
289 S X=$G(^LAH(LRLL,1,LAIEN,.1,"OBR","FID"))
290 I $P(X,"^")'="" D
291 . N FDA,LA7DIE
292 . S FDA(1,63.04,LRIDT_","_LRDFN_",",.342)=$P(X,"^")
293 . I $P(X,"^",2) S FDA(1,63.04,LRIDT_","_LRDFN_",",.32)=$P(X,"^",2)
294 . D FILE^DIE("","FDA(1)","LA7DIE(1)")
295 ;
296 ; Store ^LR( data [results]
297 S LRVF=0,LRALERT=LROUTINE,LRUSI="POC.5"
298 M LRSB=LRDATA
299 D TEST^LRVR1
300 S LRSB=0
301 F S LRSB=$O(LRSB(LRSB)) Q:LRSB<1 D Q:LRERR
302 . I '$G(^TMP("LR",$J,"TMP",LRSB,"P")) S LRERR=$$CREATE^LA7LOG(117,1) Q
303 . S LRX=$$TMPSB^LRVER1(LRSB),LRY=$P(LRSB(LRSB),U,3)
304 . F I=1:1:$L(LRX,"!") I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,"!",I)
305 . S $P(LRSB(LRSB),U,3)=LRY
306 . S LRTS=$G(^TMP("LR",$J,"TMP",LRSB))
307 . D V25^LRVER5
308 . S LRX=LRNGS,LRY=$P(LRSB(LRSB),U,5)
309 . F I=1:1:$L(LRX,U) I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,U,I)
310 . S $P(LRSB(LRSB),U,5)=LRY
311 . I $P(LRSB(LRSB),U,9)="" S $P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
312 . S ^LR(LRDFN,"CH",LRIDT,LRSB)=LRSB(LRSB)
313 ;
314 I LRERR D SENDACK^LRVRPOCU Q
315 ;
316 ; Call to set data and comments
317 I $O(LRSB(0)) D
318 . D LRSBCOM^LRVR4,A3^LRVR3
319 . S LRSTORE=LRSTORE+1
320 . I $G(LA76248) S LRSTORE(LA76248)=$G(LRSTORE(LA76248))+1
321 ;
322 ; Send application ack back to POC interface
323 D SENDACK^LRVRPOCU
324 Q
Note: See TracBrowser for help on using the repository browser.