source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LAGEN.m@ 1170

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1LAGEN ;DALOI/CJS - LAB AUTOMATED DATA ; 1 Feb 2005
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1,17,22,27,47,46,64,67**;Sep 27, 1994
3 Q
4 ;
5LOG ; Run by accession number.
6 S LINK="",LRDFN=0,DPF=2
7 I $G(LOG)<1 G LG2
8 ; If overlay data -> find if accession exists in LAH
9 I LROVER D Q:ISQN>0
10 . N I,X
11 . S (ISQN,I)=0
12 . F S I=$O(^LAH(LWL,1,"C",LOG,I)) Q:I<1 D Q:ISQN
13 . . S X=$G(^LAH(LWL,1,I,0))
14 . . ; Quit if different accession area.
15 . . I $P(X,"^",3)'=WL Q
16 . . ; Quit if different accession date and not a rollover accession (same original accession date).
17 . . I $P(X,"^",4)'=LADT,$P($G(^LRO(68,WL,1,LADT,1,LOG,0)),"^",3)'=$P($G(^LRO(68,WL,1,$P(X,"^",4),1,LOG,0)),"^",3) Q
18 . . S ISQN=I
19 . . D UPDT(LWL,ISQN)
20 I '$D(^LRO(68,WL,1,LADT,1,LOG,0)) S LINK="^^"_+LOG G LG2
21 S X=^LRO(68,WL,1,LADT,1,LOG,0),LINK=WL_U_LADT_U_LOG,LRDFN=+X,DPF=$P(X,U,2)
22LG2 D ISQN
23 I $G(LOG)>0 S ^LAH(LWL,1,"C",LOG,ISQN)="",$P(^LAH(LWL,1,ISQN,0),U,3,5)=LINK
24 I $G(CENUM)>0 S $P(^LAH(LWL,1,ISQN,0),U,6)=CENUM,^LAH(LWL,1,"D",+CENUM,ISQN)=""
25 I $D(^LRO(68.2,LWL,1,+TRAY,1,+CUP,0)) S ^(4,ISQN)=""
26 Q
27 ;
28 ;
29ISQN ;
30 L +^LAH(LWL):99999
31 ;
32 F S (^LAH(LWL),ISQN)=1+$G(^LAH(LWL)) Q:'$D(^LAH(LWL,1,ISQN))
33 ;
34 S:CUP="" TRAY=1,CUP=ISQN
35 S ^LAH(LWL,1,ISQN,0)=TRAY_U_CUP_"^^^^^"_METH_"^"_+$G(IDE)
36 ;
37 D UPDT(LWL,ISQN)
38 ;
39 S ^LAH(LWL,1,"B",(+TRAY)_";"_(+CUP),ISQN)=""
40 ;
41 ; IDE xref added to enable correct identifier for CX4/CX5 instruments
42 S ^LAH(LWL,1,"E",+$G(IDE),ISQN)=""
43 ;
44 ; Set UID xref and .3 node, used to verify by unique identifier (UID).
45 I $G(LA7UID)'="" D UID(LWL,ISQN,LA7UID)
46 ;
47 L -^LAH(LWL)
48 Q
49 ;
50 ;
51LLIST ;
52 S LRDFN=0,DPF=2
53 ;
54 I LROVER D Q:ISQN>0
55 . S ISQN=+$O(^LAH(LWL,1,"B",(+TRAY)_";"_(+CUP),0))
56 . I ISQN D UPDT(LWL,ISQN)
57 ;
58 ; Run by load/work list number sent.
59 D ISQN S LINK="^^"
60 ;
61 I $D(^LRO(68.2,LWL,1,TRAY,1,CUP,0)) S LINK=$P(^(0),"^",1,3),^(4,ISQN)=""
62 ;
63 S $P(^LAH(LWL,1,ISQN,0),U,3,5)=LINK
64 ;
65 S DPF=2
66 Q:LINK="^^"
67 S WL=+$P(LINK,"^",1),WDT=+$P(LINK,"^",2),LOG=+$P(LINK,"^",3),^LAH(LWL,1,"C",LOG,ISQN)=""
68 S X=$S($D(^LRO(68,WL,1,WDT,1,LOG,0)):^(0),1:"0^2"),DPF=+$P(X,U,2),LRDFN=+X
69 ;
70 Q
71 ;
72 ;
73SEQN ;
74 ; Run by the order data received
75 S CUP=""
76 D LLIST
77 Q
78 ;
79 ;
80CENUM ;
81 S DPF=2,LRDFN=0,LOG=$O(^LRO(68,WL,1,DT,1,"D",+CENUM,0))
82 G LOG:LOG>0 ;for martinez only
83 ;IF CENUM?1A.ANP S Y=CENUM D CEPACK I Y?.ANP S DFN=$O(^LAB(62.3,"B",Y,0)) I DFN S DPF=62.3
84 ;
85 D ISQN
86 ;
87 S ^LAH(LWL,1,"C",LOG,ISQN)="",^LAH(LWL,1,"D",+CENUM,ISQN)="",$P(^LAH(LWL,1,ISQN,0),U,6)=CENUM
88 ;
89 I $D(^LRO(68.2,LWL,1,TRAY,1,CUP,0)) S ^(4,ISQN)=""
90 Q
91 ;
92 ;
93IDENT ;
94 S DPF=2,LRDFN=0,LOG=$O(^LRO(68,WL,1,DT,1,"C",IDENT,0))
95 I LOG>0 D LOG Q
96 D ISQN
97 Q
98 ;
99 ;
100POC ; Entry point for POC interfaces to setup LAH using "E" x-ref
101 ; IDE xref used to identify for POC specimen
102 I $G(IDE)'="" D Q:ISQN
103 . S ISQN=$O(^LAH(LWL,1,"E",IDE,0))
104 . I ISQN D UPDT(LWL,ISQN) Q
105 D LOG
106 Q
107 ;
108 ;
109CONTROL ; Verify control's
110 ;
111 Q:'$D(^LRO(68,WL,1,DT,1,LOG,0)) Q:$P(^(0),U,2)'=62.3
112 ;
113 S LRDFN=+^LRO(68,WL,1,DT,1,LOG,0)
114 S IDT=+$P($G(^LRO(68,WL,1,DT,1,LOG,3)),"^",3)
115 I IDT<1 Q
116 I '$D(^LR(LRDFN,"CH",IDT,0)) Q
117 S $P(^LRO(68,WL,1,DT,1,LOG,3),U,4)=NOW
118 S $P(^LR(LRDFN,"CH",IDT,0),U,3)=NOW
119 ;
120 F I=1:0 S I=$O(^LAH(LWL,1,ISQN,I)) Q:I<1 S ^LR(LRDFN,"CH",IDT,I)=^LAH(LWL,1,ISQN,I)
121 ;
122 S:'$D(LRTEC) LRTEC=$P(^VA(200,DUZ,0),U,2)
123 ;
124 F I=0:0 S I=$O(^LRO(68,WL,1,DT,1,LOG,4,I)) Q:I<1 I +$P(^(I,0),U,3)[LWL,'$P(^(0),U,5) S $P(^(0),U,5)=NOW,$P(^(0),U,4)=LRTEC,^LRO(68,WL,1,DT,1,"AC",NOW,LOG)="",^LRO(68,WL,1,DT,1,"AD",NOW\1,LOG)=""
125 D CONTXREF
126 K:$G(LOG) ^LAH(LWL,1,"C",+LOG)
127 K ^LAH(LWL,1,"B",(+TRAY)_";"_(+CUP)),^LAH(LWL,1,ISQN)
128 ;
129 Q
130 ;
131 ;
132CEPACK S Y=$P(Y,"\",1),YY="" F I=1:1:$L(Y) S:$A(Y,I)>32 YY=YY_$E(Y,I)
133 S Y=YY
134 K YY
135 Q
136 ;
137 ;
138CONTXREF ; Set up verification X-Ref for controls
139 ;
140 N DA,LRTEST,LRTN,I,LRGTN,X1,X,S1,J,J1
141 ;
142 S LRTEST=""
143 F LRTN=0:0 S LRTN=$O(^LRO(68,WL,1,DT,1,LOG,4,LRTN)) Q:LRTN<1 I $D(^(LRTN,0)),+$P(^(0),U,3)[LWL,+$P(^(0),U,5) S:LRTEST'="" LRTEST=LRTEST_"^"_LRTN S:LRTEST="" LRTEST=LRTN
144AC ;
145 K ^TMP("LR",$J,"T")
146 D ^LREXPD
147 F X=0:0 S X=$O(^TMP("LR",$J,"T",X)) Q:X<1 S X1=$P(^(X),";",2) I X1,$D(^LR(LRDFN,"CH",IDT,X1)) S:'$D(^LRO(68,"AC",LRDFN,IDT,X1)) ^(X1)=""
148 K ^TMP("LR",$J,"T")
149 Q
150 ;
151 ;
152UPDT(LWL,ISQN) ; Set/update date/time this entry in LAH has data added.
153 ; Used by clear instrument data option to allow selective clearing based on date/time criteria.
154 ; Call with LWL = ien of load/list in LAH
155 ; ISQN = ien of sequence
156 N LANOW,LAX
157 ;
158 S LANOW=$$NOW^XLFDT
159 S LAX=$P($G(^LAH(LWL,1,ISQN,0)),"^",10,11)
160 ;
161 ; Created date/time_"^"_update date/time.
162 S LAX=$S($P(LAX,"^",1):$P(LAX,"^",1),1:LANOW)_"^"_LANOW
163 S $P(^LAH(LWL,1,ISQN,0),"^",10,11)=LAX
164 Q
165 ;
166 ;
167UID(LWL,ISQN,UID) ; Set .3 node and "U" xref with accession's UID.
168 ; Used to verify by unique identifier (UID).
169 ; Call with LWL = ien of load/list in LAH
170 ; ISQN = ien of sequence
171 ; UID = accession's UID
172 ; Called from above, LRVR1, LRVRW
173 ;
174 N X
175 ;
176 S X=$P($G(^LAH(LWL,1,ISQN,.3)),"^")
177 ; Kill x-ref if existing value different than new value.
178 I X]"",X'=UID K ^LAH(LWL,1,"U",X,ISQN)
179 ;
180 S $P(^LAH(LWL,1,ISQN,.3),"^")=UID
181 S ^LAH(LWL,1,"U",UID,ISQN)=""
182 Q
183 ;
184 ;
185POI(LWL,ISQN,NODE,LAID) ; Set .1 node with patient/order info
186 ; Call with LWL = ien of load/list in LAH
187 ; ISQN = ien of sequence
188 ; NODE = node to store data on (PID, OBR)
189 ; LAID = array containing values
190 ; PID - "DFN","DOB","ICN","LRDFN","LRTDFN","PNM","SEX","SSN"
191 ; OBR - "EOL","FID","ORCDT","ORDNLT","ORDP","PON","SID","PEB","PVB"
192 ;
193 ; ^LAH(LWL,1,ISQN,.1,"OBR","EOL") = enterer's ordering location
194 ; ^LAH(LWL,1,ISQN,.1,"OBR","FID") = filler specimen id
195 ; ^LAH(LWL,1,ISQN,.1,"OBR","ORCDT") = order date/time (FileMan d/t)
196 ; ^LAH(LWL,1,ISQN,.1,"OBR","ORDNLT") = order NLT (multiple separated by "^")
197 ; ^LAH(LWL,1,ISQN,.1,"OBR","ORDP") = ordering provider (DUZ or id^last name, first name, mi [id])
198 ; ^LAH(LWL,1,ISQN,.1,"OBR","PEB") = placer entered by (DUZ or id^last name, first name, mi [id])
199 ; ^LAH(LWL,1,ISQN,.1,"OBR","PON") = placer order number
200 ; ^LAH(LWL,1,ISQN,.1,"OBR","PVB") = placer verified by (DUZ or id^last name, first name, mi [id])
201 ; ^LAH(LWL,1,ISQN,.1,"OBR","SID") = placer specimen id
202 ; ^LAH(LWL,1,ISQN,.1,"PID","DFN") = patient's DFN in file #2
203 ; ^LAH(LWL,1,ISQN,.1,"PID","DOB") = date of birth (FileMan d/t)
204 ; ^LAH(LWL,1,ISQN,.1,"PID","ICN") = patient's ICN
205 ; ^LAH(LWL,1,ISQN,.1,"PID","LRDFN") = patient's LRDFN in file #63
206 ; ^LAH(LWL,1,ISQN,.1,"PID","LRTDFN") = patient's LRTDFN in file #67
207 ; ^LAH(LWL,1,ISQN,.1,"PID","PNM") = patient's name
208 ; ^LAH(LWL,1,ISQN,.1,"PID","SEX") = patient's sex
209 ; ^LAH(LWL,1,ISQN,.1,"PID","SSN") = patient's SSN
210 ;
211 N LAX,LAY,LAZ
212 ;
213 S LAX=""
214 F S LAX=$O(LAID(LAX)) Q:LAX="" D
215 . S LAY=LAID(LAX)
216 . I LAY="" Q
217 . S LAZ=$G(^LAH(LWL,1,ISQN,.1,NODE,LAX))
218 . I LAY=LAZ Q
219 . ; Remove old data and cross-references.
220 . I LAZ'="" D
221 . . K ^LAH(LWL,1,ISQN,.1,NODE,LAX)
222 . . I $P(LAZ,"^")]"" K ^LAH(LWL,1,"A"_LAX,$P(LAZ,"^"),ISQN)
223 . ; Set new values and cross-references.
224 . S ^LAH(LWL,1,ISQN,.1,NODE,LAX)=LAY
225 . I $P(LAY,"^")'="" S ^LAH(LWL,1,"A"_LAX,$P(LAY,"^"),ISQN)=""
226 ;
227 Q
228 ;
229 ;
230LATYP(LWL,ISQN,LAX) ; Set type of interface for this entry
231 ; Call with LWL = ien of load/list in LAH
232 ; ISQN = ien of sequence
233 ; LAX = type of interface
234 ;
235 S $P(^LAH(LWL,1,ISQN,0),"^",12)=LAX
236 Q
237 ;
238 ;
239LAMSGID(LWL,ISQN,LAX) ; Set pointer to file #62.49 for this entry.
240 ; Call with LWL = ien of load/list in LAH
241 ; ISQN = ien of sequence
242 ; LAX = ien of entry in file #62.49 that is source of these results
243 ;
244 S $P(^LAH(LWL,1,ISQN,0),"^",13)=LAX
245 S ^LAH(LWL,1,ISQN,.01,LAX)=""
246 Q
247 ;
248 ;
249METH(LWL,ISQN,LAX) ; Save instrument name/method for this entry
250 ; Call with LWL = ien of load/list in LAH
251 ; ISQN = ien of sequence
252 ; LAX = method text
253 ;
254 N X
255 S X=$P(^LAH(LWL,1,ISQN,0),"^",7)
256 I X'[LAX S X=LAX_";"_X,$P(^LAH(LWL,1,ISQN,0),"^",7)=X
257 Q
Note: See TracBrowser for help on using the repository browser.