source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7QRY2.m@ 635

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

initial load of FOIAVistA 6/30/08 version
File size: 5.2 KB
Line 
1LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 12/10/03 10:39am
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,69**;Sep 27, 1994
3 ;
4 Q
5 ;
6PATID ; Resolve patient id and establish patient environment
7 ;
8 N LA7X
9 ;
10 S (DFN,LRDFN)="",LA7PTYP=0
11 ;
12 ; SSN passed as patient identifier
13 I LA7PTID?9N.1A D
14 . S LA7PTYP=1
15 . S LA7X=$O(^DPT("SSN",LA7PTID,0))
16 . I LA7X>0 D SETDFN(LA7X)
17 ;
18 ; MPI/ICN (integration control number) passed as patient identifier
19 I LA7PTID?10N1"V"6N D
20 . S LA7PTYP=2
21 . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
22 . I LA7X>0 D SETDFN(LA7X)
23 ;
24 ; If no patient identified/no laboratory record - return exception message
25 I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
26 I 'DFN S LA7ERR(2)="No patient found with requested identifier"
27 I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
28 I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
29 Q
30 ;
31 ;
32BCD ; Search by specimen collection date.
33 ;
34 N LA763,LA7QUIT
35 ;
36 S (LA7SDT(0),LA7EDT(0))=0
37 I LA7SDT S LA7SDT(0)=9999999-LA7SDT
38 I LA7EDT S LA7EDT(0)=9999999-LA7EDT
39 ;
40 S LRSS=""
41 F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D
42 . S (LA7QUIT,LRIDT)=0
43 . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
44 . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D
45 . . ; Quit if reached end of data or outside date criteria
46 . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
47 . . D SEARCH
48 ;
49 Q
50 ;
51 ;
52BRAD ; Search by results available date (completion date).
53 ; Assumes cross-references still exist for dates in LRO(69) global.
54 ; Collects specimen date/time values for a given LRDFN and completion date.
55 ; Cross-reference is by date only, time stripped from start date.
56 ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
57 ;
58 N LA763,LA7DT,LA7ROOT,LA7SRC,X
59 ;
60 ; Check if orders still exist Iin file #69 for search range
61 S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
62 S X=$O(^LRO(69,LA7SDT(1)))
63 I X,X<LA7EDT(1) S LA7SRC=1
64 ;
65 ; Search "AN" cross-reference in file #69.
66 I LA7SRC D
67 . S LA7DT=LA7SDT(1)
68 . F S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1)) D
69 . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
70 . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D
71 . . . I $QS(LA7ROOT,6)'=LRDFN Q
72 . . . S LRIDT=$QS(LA7ROOT,7),LRSS=""
73 . . . F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D SEARCH
74 ;
75 ; If no orders in #69 then do long search through file #63.
76 I 'LA7SRC D
77 . S LRSS=""
78 . F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D
79 . . S LRIDT=0
80 . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D
81 . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
82 . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
83 ;
84 Q
85 ;
86 ;
87SEARCH ; Search subscript for a specific collection date/time
88 ;
89 K LA763
90 S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
91 ;
92 ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
93 ; Quit if specific specimen codes and they do not match
94 I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
95 E S LA761=0
96 I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
97 ;
98 ; --- Chemistry
99 I LRSS="CH" D CHSS Q
100 ; --- Microbiology
101 I LRSS="MI" D MISS Q
102 ; --- Surgical pathology
103 I LRSS="SP" D APSS Q
104 ; --- Cytology
105 I LRSS="CY" D APSS Q
106 ; --- Electron Micrscopsy
107 I LRSS="EM" D APSS Q
108 ; --- Autopsy
109 I LRSS="AU" D APSS Q
110 ; --- Blood Bank
111 I LRSS="BB" D BBSS Q
112 Q
113 ;
114 ;
115CHSS ; Search "CH" datanames for matching codes
116 ;
117 N LA7X,LRSB
118 ;
119 S LRSB=1
120 F S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB D
121 . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
122 . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
123 . D CHECK
124 Q
125 ;
126 ;
127MISS ; Search "MI" subscripts for matching codes
128 ;
129 N LA7ND,LRSB
130 ;
131 S LA7ND=0
132 F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
133 . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
134 . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
135 . D CHECK
136 Q
137 ;
138 ;
139APSS ; Search AP subscripts for matching codes
140 ; AP results are currently not coded - use defaults
141 ;
142 N LA7CODE,LRSB
143 ;
144 S LRSB=.012
145 S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
146 D CHECK
147 ;
148 Q
149 ;
150 ;
151BBSS ; Search BB subscript for matching codes
152 ; *** This subscript currently not supported ***
153 Q
154 ;
155 ;
156CHECK ; Check NLT order/result and LOINC codes.
157 ;
158 N LA7QUIT
159 ;
160 ; If wildcard then store
161 ; Otherwise check for specific NLT order/result and LOINC codes
162 I LA7SC="*" D STORE Q
163 S LA7QUIT=0
164 F I=1:1:3 D Q:LA7QUIT
165 . ; If no test code then skip
166 . I '$L($P(LA7CODE,"!",I)) Q
167 . ; If test code does not match a search code then quit
168 . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
169 . D STORE S LA7QUIT=1
170 ;
171 Q
172 ;
173 ;
174STORE ; Store entry for building in HL7 message
175 ;
176 S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
177 Q
178 ;
179 ;
180SETDFN(LA7X) ; Setup DFN and other lab variables.
181 ;
182 S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
183 Q
184 ;
185 ;***** SETUP THE SEARCH CODES
186SCLIST(SCLST) ;
187 N I,RC,SCALL,TMP K LRSSLST
188 S SCALL=",CH,MI,SP,"
189 S SCLST=$$UP^XLFSTR($TR(SCLST," ")),RC="*"
190 S:SCLST?.1"*" RC=SCLST,SCLST=$P(SCALL,",",2,999)
191 F I=1:1 S TMP=$P(SCLST,",",I) Q:TMP="" D Q:$D(LA7ERR)>1
192 . I SCALL[(","_TMP_",") S LRSSLST(TMP)="" Q
193 . S LA7ERR(7)="Invalid list of subscripts: '"_SCLST_"'"
194 Q RC
Note: See TracBrowser for help on using the repository browser.