source: ccr/trunk/p/LA7QRY2.m@ 433

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

lab changes for RPMS - LOINC codes from V Lab file
File size: 5.4 KB
RevLine 
[433]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 ; 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 ; VOE changes, Use HRN cross reference, Daou;;June 8,2005
13 S LA7X=$O(^AUPNPAT("D",LA7PTID,""))
14 I LA7X>0 D SETDFN(LA7X) S LA7PTYP=1
15 ;
16 ; See if SSN passed as patient identifier
17 I DFN'>0 S LA7X=$O(^DPT("SSN",LA7PTID,0)) I LA7X>0 D SETDFN(LA7X) S LA7PTYP=1
18 ;
19 ; MPI/ICN (integration control number) passed as patient identifier
20 I DFN'>0 S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) I LA7X>0 D SETDFN(LA7X) S LA7PTYP=2
21 ;
22 ; If no patient identified/no laboratory record - return exception message
23 I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
24 I 'DFN S LA7ERR(2)="No patient found with requested identifier"
25 I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
26 I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
27 Q
28 ;
29 ;
30BCD ; Search by specimen collection date.
31 ;
32 N LA763,LA7QUIT
33 ;
34 S (LA7SDT(0),LA7EDT(0))=0
35 I LA7SDT S LA7SDT(0)=9999999-LA7SDT
36 I LA7EDT S LA7EDT(0)=9999999-LA7EDT
37 ;
38 S LRSS=""
39 F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D
40 . S (LA7QUIT,LRIDT)=0
41 . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
42 . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D
43 . . ; Quit if reached end of data or outside date criteria
44 . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
45 . . D SEARCH
46 ;
47 Q
48 ;
49 ;
50BRAD ; Search by results available date (completion date).
51 ; Assumes cross-references still exist for dates in LRO(69) global.
52 ; Collects specimen date/time values for a given LRDFN and completion date.
53 ; Cross-reference is by date only, time stripped from start date.
54 ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
55 ;
56 N LA763,LA7DT,LA7ROOT,LA7SRC,X
57 ;
58 ; Check if orders still exist Iin file #69 for search range
59 S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
60 S X=$O(^LRO(69,LA7SDT(1)))
61 I X,X<LA7EDT(1) S LA7SRC=1
62 ;
63 ; Search "AN" cross-reference in file #69.
64 I LA7SRC D
65 . S LA7DT=LA7SDT(1)
66 . F S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1)) D
67 . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
68 . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D
69 . . . I $QS(LA7ROOT,6)'=LRDFN Q
70 . . . S LRIDT=$QS(LA7ROOT,7),LRSS=""
71 . . . F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D SEARCH
72 ;
73 ; If no orders in #69 then do long search through file #63.
74 I 'LA7SRC D
75 . S LRSS=""
76 . F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D
77 . . S LRIDT=0
78 . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D
79 . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
80 . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
81 ;
82 Q
83 ;
84 ;
85SEARCH ; Search subscript for a specific collection date/time
86 ;
87 K LA763
88 S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
89 ;
90 ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
91 ; Quit if specific specimen codes and they do not match
92 I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
93 E S LA761=0
94 I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
95 ;
96 ; --- Chemistry
97 I LRSS="CH" D CHSS Q
98 ; --- Microbiology
99 I LRSS="MI" D MISS Q
100 ; --- Surgical pathology
101 I LRSS="SP" D APSS Q
102 ; --- Cytology
103 I LRSS="CY" D APSS Q
104 ; --- Electron Micrscopsy
105 I LRSS="EM" D APSS Q
106 ; --- Autopsy
107 I LRSS="AU" D APSS Q
108 ; --- Blood Bank
109 I LRSS="BB" D BBSS Q
110 Q
111 ;
112 ;
113CHSS ; Search "CH" datanames for matching codes
114 ;
115 N LA7X,LRSB
116 ;
117 S LRSB=1
118 F S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB D
119 . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
120 . I $P($P(LA7X,"^",3),"!",3)="",$D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
121 . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
122 . D CHECK
123 ;
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.