source: ccr/trunk/labRPMS/C0CLA7Q.m@ 445

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

create temporary fork for RPMS lab extractions due to RPMS patch level
File size: 4.6 KB
Line 
1C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Apr 21, 2009
2 ;;n.n;;****;
3 ;
4 ;
5 Q
6 ;
7 ;
8LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query
9 ;
10 ;
11 K ^TMP("C0C-VLAB",$J)
12 ;
13 ; Check and retrieve lab results from LAB DATA file (#63)
14 S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
15 ;
16 ; If V LAB file present then check for lab results that are only in this file
17 ; If results found in V Lab file then build results and add to above results.
18 I $D(^AUPNVLAB) D
19 . D VCHECK
20 . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
21 ;
22 ;K ^TMP("C0C-VLAB",$J)
23 ;
24 Q C0CDEST
25 ;
26 ;
27VCHECK ; If V LAB file present then check for lab results that are only in this file.
28 ;
29 N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
30 ;
31 S LA7PTID=C0CPTID
32 D PATID^LA7QRY2
33 I $D(LA7ERR) Q
34 ;
35 ; Resolve search codes to lab datanames
36 S LA7SC=$G(C0CSC)
37 I $T(SCLIST^LA7QRY2)'="" D
38 . N TMP
39 . S LA7SCSRC=$G(C0CSC)
40 . S TMP=$$SCLIST^LA7QRY2(LA7SCSRC)
41 . S LA7SC=TMP
42 ;
43 I LA7SC'="*" D CHKSC^LA7QRY1
44 ;
45 ; Convert specimen codes to file #61 Topography entries
46 S LA7SPEC=$G(C0CSPEC)
47 I LA7SPEC'="*" D SPEC^LA7QRY1
48 ;
49 S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
50 ;
51 F S C0CROOT=$Q(@C0CROOT) Q:C0CROOT="" D Q:C0CEND
52 . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q ; Left x-ref or patient
53 . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q ; Exceeded end date/time
54 . S C0CDA=$QS(C0CROOT,4)
55 . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q ; Already checked during scan of file #63
56 . D VCHK1
57 ;
58 ;
59 Q
60 ;
61 ;
62VBUILD ; Build results found only in V LAB file into HL7 structure.
63 ;
64 ;
65 Q
66 ;
67 ;
68LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
69 ; Call from LA7QRY2
70 ;
71 N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
72 ;
73 S DFN=$P(^LR(LRDFN,0),"^",3)
74 S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
75 S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
76 S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
77 ;
78 ; ^AUPNVLAB("ALR1",5380,3080307.211055,"EKT 0307 48",188,5427202)=""
79 ;
80 S C0C60=""
81 F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'=""
82 . D FINDDT
83 . I C0CDA<1 Q
84 . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
85 . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
86 . I C0CPDA="" S C0CPDA=C0CDA
87 . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
88 . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
89 . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
90 . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
91 . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
92 . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
93 . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
94 ;
95 S X=$P(LA7X,"^",3)
96 ; If order NLT then update if no order NLT
97 I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
98 ;
99 ; If result NLT then update if no result NLT
100 I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
101 ;
102 ; If LOINC found then update variable with LN code
103 I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
104 ;
105 S $P(LA7X,"^",3)=X
106 ;
107 Q
108 ;
109 ;
110TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
111 ; Called from LA7VOBX1
112 ;
113 N I,X
114 ;
115 S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
116 I X="" Q
117 F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
118 S $P(LA7VAL,"^",3)=LA7X
119 ;
120 Q
121 ;
122 ;
123VCHK1 ; Check the entry in V Lab to determine if it meets criteria
124 ;
125 N C0CVLAB,I
126 ;
127 F I=0,12 S C0CVLAB(I)=^AUPNVLAB(C0CDA,I)
128 ;
129 ; JMC 04/13/09 - Store anything for now that meets date criteria.
130 D VSTORE
131 ;
132 Q
133 ;
134 ;
135VSTORE ; Store entry for building in HL7 message when parent is from V LAB file.
136 ;
137 N C0CPDA,C0CPTEST
138 ;
139 ; Determine parent test to use for OBR segment
140 S C0CPDA=$P(C0CVLAB(12),"^",8)
141 I C0CPDA="" S C0CPDA=C0CDA
142 ;
143 ; Determine parent test
144 S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
145 ;
146 S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
147 ;
148 Q
149 ;
150 ;
151FINDDT ; Find entry in V LAB for the date/time or one close to it.
152 ; RPMS stores related specimen entries under the same date/time.
153 ; Lab file #63 creates unique entries with slightly different times.
154 ;
155 S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
156 I C0CDA>0 Q
157 ;
158 ; If entry found then confirm that specimen type matches.
159 N C0CDTY
160 S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
161 I C0CDTY D
162 . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
163 . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
164 . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
165 ;
166 Q
Note: See TracBrowser for help on using the repository browser.