source: WorldVistAEHR/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7QRY2.m@ 846

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

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