source: ccr/trunk/labRPMS/LA7QRY2.m@ 1501

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

create temporary fork for RPMS lab extractions due to RPMS patch level
File size: 4.8 KB
Line 
1LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994
3 ; JMC - mods to check for IHS V LAB file
4 ;
5 Q
6 ;
7PATID ; Resolve patient id and establish patient environment
8 ;
9 N LA7X
10 ;
11 S (DFN,LRDFN)="",LA7PTYP=0
12 ;
13 ; SSN passed as patient identifier
14 I LA7PTID?9N.1A D
15 . S LA7PTYP=1
16 . S LA7X=$O(^DPT("SSN",LA7PTID,0))
17 . I LA7X>0 D SETDFN(LA7X)
18 ;
19 ; MPI/ICN (integration control number) passed as patient identifier
20 I LA7PTID?10N1"V"6N D
21 . S LA7PTYP=2
22 . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
23 . I LA7X>0 D SETDFN(LA7X)
24 ;
25 ; If no patient identified/no laboratory record - return exception message
26 I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
27 I 'DFN S LA7ERR(2)="No patient found with requested identifier"
28 I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
29 I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
30 Q
31 ;
32 ;
33BCD ; Search by specimen collection date.
34 ;
35 N LA763,LA7QUIT
36 ;
37 S (LA7SDT(0),LA7EDT(0))=0
38 I LA7SDT S LA7SDT(0)=9999999-LA7SDT
39 I LA7EDT S LA7EDT(0)=9999999-LA7EDT
40 ;
41 F LRSS="CH","MI","SP" 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)
73 . . . F LRSS="CH","MI","SP" D SEARCH
74 ;
75 ; If no orders in #69 then do long search through file #63.
76 I 'LA7SRC D
77 . F LRSS="CH","MI","SP" D
78 . . S LRIDT=0
79 . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D
80 . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
81 . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
82 ;
83 Q
84 ;
85 ;
86SEARCH ; Search subscript for a specific collection date/time
87 ;
88 K LA763
89 S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
90 ;
91 ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
92 ; Quit if specific specimen codes and they do not match
93 I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
94 E S LA761=0
95 I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
96 ;
97 ; --- Chemistry
98 I LRSS="CH" D CHSS Q
99 ; --- Microbiology
100 I LRSS="MI" D MISS Q
101 ; --- Surgical pathology
102 I LRSS="SP" D APSS Q
103 ; --- Cytology
104 I LRSS="CY" D APSS Q
105 ; --- Electron Micrscopsy
106 I LRSS="EM" D APSS Q
107 ; --- Autopsy
108 I LRSS="AU" D APSS Q
109 ; --- Blood Bank
110 I LRSS="BB" D BBSS Q
111 Q
112 ;
113 ;
114CHSS ; Search "CH" datanames for matching codes
115 ;
116 N LA7X,LRSB
117 ;
118 S LRSB=1
119 F S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB D
120 . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
121 . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
122 . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
123 . D CHECK
124 ;
125 Q
126 ;
127 ;
128MISS ; Search "MI" subscripts for matching codes
129 ;
130 N LA7ND,LRSB
131 ;
132 S LA7ND=0
133 F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
134 . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
135 . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
136 . D CHECK
137 Q
138 ;
139 ;
140APSS ; Search AP subscripts for matching codes
141 ; AP results are currently not coded - use defaults
142 ;
143 N LA7CODE,LRSB
144 ;
145 S LRSB=.012
146 S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
147 D CHECK
148 ;
149 Q
150 ;
151 ;
152BBSS ; Search BB subscript for matching codes
153 ; *** This subscript currently not supported ***
154 Q
155 ;
156 ;
157CHECK ; Check NLT order/result and LOINC codes.
158 ;
159 N LA7QUIT
160 ;
161 ; If wildcard then store
162 ; Otherwise check for specific NLT order/result and LOINC codes
163 I LA7SC="*" D STORE Q
164 S LA7QUIT=0
165 F I=1:1:3 D Q:LA7QUIT
166 . ; If no test code then skip
167 . I '$L($P(LA7CODE,"!",I)) Q
168 . ; If test code does not match a search code then quit
169 . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
170 . D STORE S LA7QUIT=1
171 ;
172 Q
173 ;
174 ;
175STORE ; Store entry for building in HL7 message
176 ;
177 S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
178 Q
179 ;
180 ;
181SETDFN(LA7X) ; Setup DFN and other lab variables.
182 ;
183 S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
184 Q
Note: See TracBrowser for help on using the repository browser.