source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRVRPOCU.m@ 1791

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

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1LRVRPOCU ;DALOI/JMC - POINT OF CARE UTILITY PROGRAM ; May 10, 2004 12:06
2 ;;5.2;LAB SERVICE;**290**;Sep 27, 1994
3 ;
4 ; Reference to DUZ^XUP supported by DBIA #4129
5 ; Reference to DIVSET^XUSRB2 supported by DBIA #4055
6 ;
7 Q
8 ;
9 ;
10INIT ; Initialize user
11 ;
12 N I,LR60,LR61,LR62,LR64,LR0070,LRNLT,LRX,LRY
13 S (LRCNT,LREND,LRSTORE)=0,(DIQUIET,LRNOECHO,LRQUIET)=1,LAMSG=""
14 K LRDUZ,LRERR,LRIEN,LRORDNLT
15 D KVAR^VADPT
16 S LRX=$$FIND1^DIC(200,"","OX","LRLAB,POC","B","")
17 I LRX<1 D Q
18 . S LREND=1
19 . S LAMSG="Unable to identify user 'LRLAB,POC' in NEW PERSON file"
20 D DUZ^XUP(LRX)
21 ;
22 D EN^LRPARAM
23 I $G(LREND) S LAMSG="LRPARAM Error for Load/Work List "_$P(LRLL(0),"^") Q
24 S $P(LRPARAM,U,3)="",$P(LRPARAM,U,4)=""
25 S LRLABKY="1^^^1" ;lab verification keys
26 ;
27 ; Get list of test and setup variables
28 S (LRORDR,LRLWC)="P" ; Order type POC
29 S LRTYPE=+$P($G(^LRO(68.2,LRLL,0)),U,3)
30 ;
31 S LRPROF=$O(^LRO(68.2,LRLL,10,0))
32 I 'LRPROF D Q
33 . S LREND=1
34 . S LAMSG="No Profile for Load/Work List "_$P(LRLL(0),"^")
35 ;
36 S LRPROF(0)=^LRO(68.2,LRLL,10,LRPROF,0)
37 S (LRDAA,LRAA)=$P(LRPROF(0),U,2)
38 I $S('$G(LRDAA):1,'$D(^LRO(68,LRDAA,0))#2:1,1:0) D Q
39 . S LREND=1
40 . S LAMSG="No Default accession area for Load/Work List "_$P(LRLL(0),"^")
41 I $P(^LRO(68,LRAA,0),U,2)'="CH" S LREND=1,LAMSG="No CH accession area for Load/Work List "_$P(LRLL(0),"^") Q
42 ;
43 I $$GET1^DIQ(68,LRDAA_",",.4)="" D Q
44 . S LREND=1
45 . S LAMSG="No Numeric Identifier for Accession Area "_$$GET1^DIQ(68,LRDAA_",",.01)
46 ;
47 S LRX=$G(^LRO(68,LRAA,0))
48 S LRLD=$S($P(LRX,U,19)'="":$P(LRX,U,19),1:"CP")
49 ;
50 S LRDFWKLD=+$G(^LRO(68.2,LRLL,"SUF"))
51 D WKLD(LRDFWKLD)
52 I LRCDEF="" D Q
53 . S LREND=1
54 . S LAMSG="No Default Suffix for Load/Work List "_$P(LRLL(0),"^")
55 ;
56 ; Explode the test list
57 K ^TMP("LR",$J)
58 D EXPLODE^LRGP2
59 I '$O(^TMP("LR",$J,"VTO",0)) D Q
60 . S LREND=1
61 . S LAMSG="No Test defined for Load/Work List "_$P(LRLL(0),"^")
62 ;
63 ; Build array of order NLT codes and corresponding file #60 tests.
64 S I=0
65 F S I=$O(^LRO(68.2,LRLL,10,LRPROF,1,I)) Q:'I D
66 . S LRY=$G(^LRO(68.2,LRLL,10,LRPROF,1,I,0)),(LR0070,LR62)=""
67 . S LR60=+LRY,LR61=$P(LRY,"^",2),LR64=+$G(^LAB(60,LR60,64))
68 . I LR64 D
69 . . S LRNLT=$P($G(^LAM(LR64,0)),"^",2)
70 . . I LR61 D
71 . . . S LR0070=$$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR")
72 . . . S LR62=$P(LRY,"^",5)
73 . . . I 'LR62 S LR62=$$GET1^DIQ(61,LR61_",",4.1,"I")
74 . . I LRNLT'="",LR0070'="" S LRORDNLT(LRNLT,LR0070)=LR60_"^"_LR61_"^"_LR62_"^"_$P(LRY,"^",4)
75 ;
76 K LRIEN,LRERR
77 S LRDPF="2^DPT(",(LRERR,VAERR)=0,(LRLBLBP,LREAL,LRASSN,VA200,COMB)=""
78 S LROUTINE=$$GET1^DIQ(69.9,"1,",301,"I","ANS","ERR") ;Routine urgency
79 S:'LROUTINE LROUTINE=9
80 S LRALERT=LROUTINE
81 ;
82 I $$GET1^DIQ(68.2,LRLL_",",.03,"I")'=2 D Q
83 . S LREND=1
84 . S LAMSG="Load/Work List "_$P(LRLL(0),"^")_" not set to POC type."
85 ;
86 ; Determine division to set user LRLAB,POC.
87 S LRDIV=$O(^LRO(68,LRDAA,3,0))
88 I LRDIV<1 D Q
89 . S LREND=1
90 . S LAMSG="No associated division for accession area "_$$GET1^DIQ(68,LRDAA_",",.01)
91 I LRDIV'=DUZ(2) D Q:LREND
92 . S LRY=0
93 . D DIVSET^XUSRB2(.LRY,"`"_LRDIV)
94 . I LRY Q
95 . S LREND=1,LAMSG="Unable to set user 'LRLAB,POC' to division "_$$GET1^DIQ(4,LRDIV_",",.01)
96 ;
97 ; Set CPRS nature of order to 'AUTO'.
98 S LRNATURE=$P($$NEW1^LROR6(9),"^",4,6)
99 ;
100 S LRVBY=2
101 Q
102 ;
103 ;
104WKLD(LRP) ; Setup LRCDEF* variables for workload
105 ; Call with LRP = ien of WKLD suffix in file #64.2
106 S LRCDEF0=$G(^LAB(64.2,LRP,0)),LRCDEF0(1)=$P(LRCDEF0,"^",19)
107 S LRCDEF=$P($P(LRCDEF0,"^",2),".",2)
108 ;
109 Q
110 ;
111 ;
112SPALERT ; Send Processing Alert Message
113 ;
114 N LAMSG,LRTIME,LRX
115 S LRX=0,LRTIME=$$HTE^XLFDT($H,"1M")
116 F S LRX=$O(LRSTORE(LRX)) Q:'LRX D
117 . I '$D(^LAHM(62.48,LRX,20,"B",1)) Q ; New result alerts not defined
118 . S LAMSG=$P(LRSTORE(LRX),"^")_" Patient(s) processed for POC: "_$$GET1^DIQ(62.48,LRX_",",.01)_" on "_LRTIME
119 . D XQA^LA7UXQA(1,LRX,"","",LAMSG,"",1)
120 Q
121 ;
122 ;
123CLEAN ;Clean-up point
124 D KVAR^VADPT
125 K AGE,COMB,CONTROL,DFN,DOB,DTS,H8,I5
126 K LRACC,LRACD,LRAD,LRAN,LRAOD
127 K LRASSN,LRCAPLOC,LRCDT,LRCDEF,LRCDEF0,LRCDEF0X,LRCODEN,LRCOM
128 K LRDATA,LRERR,LRNOCODE,LROLDIV
129 K LRPRAC,LRRB
130 K LRSB,LRSN,LRSQ,LRSSCX,LRSSN,LRSUB,LRSXN,LRST,LRSUB,LRSUM
131 K LRSXN,LRT,LRTN,LRTREA,LRTS,LRTSORU,LRTST,LRTT,LRUID
132 K LRUNQ,LRWRD,PNM,S5,SEGID,SEX,SSN
133 K LRIDT,LRIN,LRIX,LRBLBP,LRM,LRNLT,LRNOW,LRNT,LRNX,LRODT
134 K LROLLOC,LRORD,LRODTIM,LRORU3,LROT,OCXAP
135 K T1,VA,VADMVT,VAINDT,VAL,XP,Z
136 Q
137 ;
138 ;
139VASD ; Check for clinic appointment at same time as specimen
140 ; else for clinic appointment before specimen date/time on same date.
141 ;
142 ; If unable to find an appointment before the specimen date/time then
143 ; look for first appointment after specimen date/time.
144 ;
145 ; If ordering division in message then only check those clinic locations
146 ; that are in the same division.
147 ;
148 N LRDATE,LRCLIEN,LRCOUNT,LRENC,LREXACT,LRP,LRX,LRY
149 S (LRDATE,LRENC,LREXACT,LRY)=0
150 S LRP(1)=(LRCDT\1)_";"_(LRCDT\1)
151 S LRP(3)="R;I;NT"
152 S LRP(4)=DFN
153 S LRP("FLDS")="2;12"
154 S LRP("SORT")="P"
155 S LRCOUNT=$$SDAPI^SDAMA301(.LRP)
156 I LRCOUNT>0 D
157 . I 'LROLLOC D FINDAPPT Q
158 . I LROLLOC,'LRPRAC D CHKAPPT
159 ;
160 I LRCOUNT'=0 K ^TMP($J,"SDAMA301")
161 ;
162 ; If no provider then try provider from outpatient encounter.
163 I 'LRPRAC,LROLLOC,LRENC D OENC(LRENC)
164 Q
165 ;
166 ;
167FINDAPPT ; Find an appointment for the collection date/time
168 F S LRDATE=$O(^TMP($J,"SDAMA301",DFN,LRDATE)) Q:LRDATE="" D Q:LREXACT
169 . S LRX=$G(^TMP($J,"SDAMA301",DFN,LRDATE))
170 . S LRCLIEN=$P($P(LRX,"^",2),";")
171 . I LROLDIV,LROLDIV'=$$GET1^DIQ(44,LRCLIEN_",",3,"I") Q
172 . I LRDATE=LRCDT S LROLLOC=LRCLIEN,LRENC=$P(LRX,"^",12),LREXACT=1 Q
173 . I 'LRY,LRDATE<LRCDT S LRY=LRX,LROLLOC=LRCLIEN,LRENC=$P(LRX,"^",12) Q
174 . I 'LRY,LRDATE>LRCDT S LRY=LRX,LROLLOC=LRCLIEN,LRENC=$P(LRX,"^",12) Q
175 . I LRDATE>LRY,LRDATE<LRCDT S LRY=LRX,LROLLOC=LRCLIEN,LRENC=$P(LRX,"^",12)
176 Q
177 ;
178 ;
179CHKAPPT ; Check for an appointment that matches the ordering location
180 ; to find the provider on the encounter when no provider sent.
181 F S LRDATE=$O(^TMP($J,"SDAMA301",DFN,LRDATE)) Q:LRDATE="" D Q:LRENC
182 . S LRX=$G(^TMP($J,"SDAMA301",DFN,LRDATE))
183 . S LRCLIEN=$P($P(LRX,"^",2),";")
184 . I LROLLOC=LRCLIEN S LRENC=$P(LRX,"^",12) Q
185 Q
186 ;
187 ;
188OENC(LRENC) ; Lookup provider on encounter
189 ; Use primary provider if possbile otherwise use first provider listed.
190 ;
191 N LRI,LRPRVLST,LRERR
192 D GETPRV^SDOE(LRENC,"LRPRVLST","LRERR")
193 I $G(LRPRVLST)<1 Q
194 S LRI=0
195 F S LRI=$O(LRPRVLST(LRI)) Q:'LRI D Q:LRPRAC
196 . I $P(LRPRVLST(LRI),"^",4)="P" S LRPRAC=+LRPRVLST(LRI) Q
197 I 'LRPRAC S LRI=$O(LRPRVLST(0)),LRPRAC=+LRPRVLST(LRI)
198 Q
199 ;
200 ;
201SENDACK ; Send HL7 ACKnowledgment message
202 ;
203 N LA
204 S LA(62.48)=LA76248,LA(62.49)=LA76249
205 S LA("ACK")=$S(+LRERR:"AE",1:"AA")
206 S LA("MSG")=$S($G(LRUID)'="":LRUID_"^",1:"")
207 S LA("MSG")=LA("MSG")_$P(LRERR,"^",2)
208 D ACK^LA7POC(.LA)
209 Q
Note: See TracBrowser for help on using the repository browser.