Changeset 529 for ccr/trunk/p/C0CLA7Q.m
- Timestamp:
- Jun 1, 2009, 10:27:32 PM (15 years ago)
- File:
-
- 1 edited
-
ccr/trunk/p/C0CLA7Q.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/trunk/p/C0CLA7Q.m
r508 r529 1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;May 4, 2009 2 ;;1.0;C0C;;May 19, 2009; 3 ;;n.n;;****; 4 ; 5 ; 6 Q 7 ; 8 ; 1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;May 31, 2009 2 ;;1.0;C0C;;May 19, 2009; 3 ; 4 ; 5 Q 6 ; 7 ; 9 8 LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 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 ; 28 27 VCHECK ; If V LAB file present then check for lab results that are only in this file. 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 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 . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q ; Source is LAB DATA file - skip 57 . D VCHK1 58 ; 59 ; 60 Q 61 ; 62 ; 64 63 VBUILD ; Build results found only in V LAB file into HL7 structure. 65 66 67 68 69 64 ; 65 ; 66 Q 67 ; 68 ; 70 69 LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63. 71 ; Call from LA7QRY2 72 ; 73 N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X 74 ; 75 S DFN=$P(^LR(LRDFN,0),"^",3) 76 S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0) 77 S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5) 78 S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)="" 79 ; 80 ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)="" 81 ; 82 S C0C60="" 83 F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'="" 84 . D FINDDT 85 . I C0CDA<1 Q 86 . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q ; Source is not LAB DATA file - skip 87 . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13) 88 . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8) 89 . I C0CPDA="" S C0CPDA=C0CDA 90 . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2) 91 . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2) 92 . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^") 93 . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2) 94 . S ^TMP("C0C-VLAB",$J,1,C0CDA)="" 95 . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)="" 96 . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST 97 ; 98 S X=$P(LA7X,"^",3) 99 ; If order NLT then update if no order NLT 100 I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64) 101 ; 102 ; If result NLT then update if no result NLT 103 I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64) 104 ; 105 ; If LOINC found then update variable with LN code 106 I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN 107 ; 108 S $P(LA7X,"^",3)=X 109 ; 110 Q 111 ; 112 ; 70 ; Call from LA7QRY2 71 ; 72 N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X 73 ; 74 S DFN=$P(^LR(LRDFN,0),"^",3) 75 S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0) 76 S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5) 77 S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)="" 78 ; 79 ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)="" 80 ; 81 S C0C60="" 82 F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'="" 83 . D FINDDT 84 . I C0CDA<1 Q 85 . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q ; Source is not LAB DATA file - skip 86 . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13) 87 . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8) 88 . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer 89 . I C0CPDA="" S C0CPDA=C0CDA 90 . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2) 91 . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2) 92 . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^") 93 . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2) 94 . S ^TMP("C0C-VLAB",$J,1,C0CDA)="" 95 . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)="" 96 . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST 97 ; 98 S X=$P(LA7X,"^",3) 99 ; If order NLT then update if no order NLT 100 I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64) 101 ; 102 ; If result NLT then update if no result NLT 103 I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64) 104 ; 105 ; If LOINC found then update variable with LN code 106 I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN 107 ; 108 S $P(LA7X,"^",3)=X 109 ; 110 Q 111 ; 112 ; 113 113 TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments 114 115 116 117 118 119 120 121 122 123 124 125 114 ; Called from LA7VOBX1 115 ; 116 N I,X 117 ; 118 S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) 119 I X="" Q 120 F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I) 121 S $P(LA7VAL,"^",3)=LA7X 122 ; 123 Q 124 ; 125 ; 126 126 VCHK1 ; Check the entry in V Lab to determine if it meets criteria 127 128 129 130 131 132 133 134 135 136 137 127 ; 128 N C0CVLAB,I 129 ; 130 F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I)) 131 ; 132 ; JMC 04/13/09 - Store anything for now that meets date criteria. 133 D VSTORE 134 ; 135 Q 136 ; 137 ; 138 138 VSTORE ; Store entry for building in HL7 message when parent is from V LAB file. 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 139 ; 140 N C0CPDA,C0CPTEST 141 ; 142 ; Determine parent test to use for OBR segment 143 S C0CPDA=$P(C0CVLAB(12),"^",8) 144 I C0CPDA="" S C0CPDA=C0CDA 145 ; 146 ; Determine parent test 147 S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^") 148 ; 149 S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA 150 ; 151 Q 152 ; 153 ; 154 154 FINDDT ; Find entry in V LAB for the date/time or one close to it. 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 155 ; RPMS stores related specimen entries under the same date/time. 156 ; Lab file #63 creates unique entries with slightly different times. 157 ; 158 S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0)) 159 I C0CDA>0 Q 160 ; 161 ; If entry found then confirm that specimen type matches. 162 N C0CDTY 163 S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0)) 164 I C0CDTY D 165 . I $P(C0CDT,".")'=$P(C0CDTY,".") Q 166 . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0)) 167 . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA="" 168 ; 169 Q
Note:
See TracChangeset
for help on using the changeset viewer.
