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

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

rollback of Lab for RPMS code
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.