From 02fc269be1b5b524df321f5a86044457a4079c83 Mon Sep 17 00:00:00 2001 From: george Date: Tue, 14 Apr 2009 02:03:39 +0000 Subject: [PATCH] lab changes for RPMS - LOINC codes from V Lab file --- p/C0CFM2.m | 7 +- p/C0CLA7Q.m | 106 ++++++++++++++++++++++++++++ p/LA7QRY2.m | 194 +++++++++++++++++++++++++++++++++++++++++++++++++++ p/LA7VOBX1.m | 129 ++++++++++++++++++++++++++++++++++ 4 files changed, 433 insertions(+), 3 deletions(-) create mode 100644 p/C0CLA7Q.m create mode 100644 p/LA7QRY2.m create mode 100644 p/LA7VOBX1.m diff --git a/p/C0CFM2.m b/p/C0CFM2.m index 44b0dde..1a509e7 100644 --- a/p/C0CFM2.m +++ b/p/C0CFM2.m @@ -29,7 +29,7 @@ C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 ; RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE ; - I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS + I '$D(RIMBASE) D ASETUP^C0CRIMA ; FOR COMMAND LINE CALLS N ZI,ZJ,ZC,ZPATBASE S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) S ZI="" @@ -40,7 +40,7 @@ RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE ; PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE ; - S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN)) + S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) I '$D(ZWHICH) S ZWHICH="ALL" I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) @@ -123,7 +123,8 @@ PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_"," . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN - . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=@ZVALS@(ZC0CI) + . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|") + . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL . E D ; THIS IS A SUBELEMENT . . ;PUT THE FOLLOWING BACK TO USE RECURSION . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV diff --git a/p/C0CLA7Q.m b/p/C0CLA7Q.m new file mode 100644 index 0000000..abc660a --- /dev/null +++ b/p/C0CLA7Q.m @@ -0,0 +1,106 @@ +C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Apr 12, 2009 + ;;5.2;;****;Sep 27, 1994 + ; + ; + Q + ; + ; +LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query + ; + ; + K ^TMP("C0C-VLAB",$J) + ; + ; Check and retrieve lab results from LAB DATA file (#63) + D GCPR^LA7QRY(C0CPTID,C0CSDT,C0CEDT,.C0CSC,.C0CSPEC,.C0CERR,C0CDEST,C0CHL7) + ; + ; If V LAB file present then check for lab results that are only in this file + I $D(^AUPNVLAB) D VCHECK + ; + ; If results found in V Lab file then build results and add to above results. + I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD + ; + ;K ^TMP("C0C-VLAB",$J) + ; + Q C0CDEST + ; + ; +VCHECK ; If V LAB file present then check for lab results that are only in this file. + ; + N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SCRC,LA7SPEC,TMP + ; + S LA7PTID=C0CPTID + D PATID^LA7QRY2 + I $D(LA7ERR) Q + ; + ; Resolve search codes to lab datanames + S LA7SCSRC=$G(C0CSC) + S TMP=$$SCLIST^LA7QRY2(LA7SCSRC) + Q:$D(LA7ERR) "" + S LA7SC=TMP D:LA7SC'="*" CHKSC^LA7QRY1 + ; + ; Convert specimen codes to file #61 Topography entries + S LA7SPEC=$G(C0CSPEC) + I LA7SPEC'="*" D SPEC^LA7QRY1 + ; + S C0CROOT="^AUPNVLAB(""ALR4"",DFN,COCSDT)",C0CEND=0 + ; + F S C0CROOT=$Q(@C0CROOT) Q:C0CROOT="" D Q:C0CEND + . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q ; Left x-ref or patient + . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q ; Exceeded end date/time + . S C0CDA=$QS(C0CROOT,6) + . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q ; Already checked during scan of file #63 + . D VCHK1 + ; + ; + Q + ; + ; +VBUILD ; Build results found only in V LAB file into HL7 structure. + ; + ; + Q + ; + ; +LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63. + ; Call from LA7QRY2 + ; + N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,X + ; + S DFN=$P(^LR(LRDFN,0),"^",3) + S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0) + S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6) + ; + ; ^AUPNVLAB("ALR1",5380,3080307.211055,"EKT 0307 48",188,5427202)="" + ; + S C0C60=0,C0CLN="" + F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'="" + . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CDT,C0CACC,C0C60,0)) + . I C0CDA<1 Q + . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13) + . S ^TMP("C0C-VLAB",$J,1,C0CDA)="" + . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CLN_"^"_C0CDA + ; + ; If LOINC found then update variable with LN code + I C0CLN'="" D + . S X=$P(LA7X,"^",3) + . S $P(X,"!",3)=C0CLN + . S $P(LA7X,"^",3)=X + ; + Q + ; + ; +VCHK1 ; Check the entry in V Lab to determine if it meets criteria + ; + N C0CVLAB,I + ; + F I=0,12 S C0CVLAB(I)=^AUPNVLAB(C0CDA,I) + ; + D VSTORE + ; + Q + ; + ; +VSTORE ; Store entry for building in HL7 message when parent is from V LAB file. + ; + S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(12),"^"),$P(C0CVLAB,"^",2))="" + Q diff --git a/p/LA7QRY2.m b/p/LA7QRY2.m new file mode 100644 index 0000000..cae06ff --- /dev/null +++ b/p/LA7QRY2.m @@ -0,0 +1,194 @@ +LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ;1/30/07 19:05 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,69,73**;Sep 27, 1994;Build 7 + ; JMC - mods to check for IHS V LAB file + ; + Q + ; +PATID ; Resolve patient id and establish patient environment + ; + N LA7X + ; + S (DFN,LRDFN)="",LA7PTYP=0 + ; VOE changes, Use HRN cross reference, Daou;;June 8,2005 + S LA7X=$O(^AUPNPAT("D",LA7PTID,"")) + I LA7X>0 D SETDFN(LA7X) S LA7PTYP=1 + ; + ; See if SSN passed as patient identifier + I DFN'>0 S LA7X=$O(^DPT("SSN",LA7PTID,0)) I LA7X>0 D SETDFN(LA7X) S LA7PTYP=1 + ; + ; MPI/ICN (integration control number) passed as patient identifier + I DFN'>0 S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) I LA7X>0 D SETDFN(LA7X) S LA7PTYP=2 + ; + ; If no patient identified/no laboratory record - return exception message + I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed" + I 'DFN S LA7ERR(2)="No patient found with requested identifier" + I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient" + I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient" + Q + ; + ; +BCD ; Search by specimen collection date. + ; + N LA763,LA7QUIT + ; + S (LA7SDT(0),LA7EDT(0))=0 + I LA7SDT S LA7SDT(0)=9999999-LA7SDT + I LA7EDT S LA7EDT(0)=9999999-LA7EDT + ; + S LRSS="" + F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D + . S (LA7QUIT,LRIDT)=0 + . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1) + . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D + . . ; Quit if reached end of data or outside date criteria + . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q + . . D SEARCH + ; + Q + ; + ; +BRAD ; Search by results available date (completion date). + ; Assumes cross-references still exist for dates in LRO(69) global. + ; Collects specimen date/time values for a given LRDFN and completion date. + ; Cross-reference is by date only, time stripped from start date. + ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)="" + ; + N LA763,LA7DT,LA7ROOT,LA7SRC,X + ; + ; Check if orders still exist Iin file #69 for search range + S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0 + S X=$O(^LRO(69,LA7SDT(1))) + I X,XLA7EDT(1)) D + . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")" + . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D + . . . I $QS(LA7ROOT,6)'=LRDFN Q + . . . S LRIDT=$QS(LA7ROOT,7),LRSS="" + . . . F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D SEARCH + ; + ; If no orders in #69 then do long search through file #63. + I 'LA7SRC D + . S LRSS="" + . F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D + . . S LRIDT=0 + . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D + . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) + . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)1 + . I SCALL[(","_TMP_",") S LRSSLST(TMP)="" Q + . S LA7ERR(7)="Invalid list of subscripts: '"_SCLST_"'" + Q RC diff --git a/p/LA7VOBX1.m b/p/LA7VOBX1.m new file mode 100644 index 0000000..d59dcf8 --- /dev/null +++ b/p/LA7VOBX1.m @@ -0,0 +1,129 @@ +LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd ;Apr 8, 2009 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63,64,71**;Sep 27, 1994 + ; JMC - mods to check for IHS V LAB file + ; +CH ; Observation/Result segment for "CH" subscript results. + ; Called by LA7VOBX + ; + N LA76304,LA7ALT,LA7DIV,LA7I,LA7RS,LA7X,LA7Y,X + ; + ; "CH" subscript requires a dataname + I '$G(LRSB) Q + ; + ; get result node from LR global. + S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) + S LA7RS=$P(LRSB,"^",2),LRSB=$P(LRSB,"^") + S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) + ; If previous results have been corrected then send corrected status + I LA7RS="",$P(LA7VAL,"^",10)=2 S LA7RS="C" + ; + ; Check if test is OK to send - (O)utput or (B)oth + S LA7X=$P(LA7VAL,"^",12) + I LA7X]"","BO"'[LA7X Q + I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",7)) Q + ; + ; If no result NLT or LOINC try to determine from file #60 + S LA7X=$P(LA7VAL,"^",3) + ; + ; Check for no LOINC in 63 and LOINC found in V LAB file. + I $P(LA7X,"!",3)="",$D(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) S $P(LA7X,"!",3)=$P(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB),"^") + ; + I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5)) + ; No result NLT code - log error + I $P($P(LA7VAL,"^",3),"!",2)="" D + . N LA7X + . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL") + . D CREATE^LA7LOG(36) + ; + ; something missing - No NLT code, etc. + I LA7VAL="" Q + ; + ; Check for missing units/reference ranges + S LA7X=$P(LA7VAL,"^",5) + ; + ; Results missing units, lookup in file #60 + I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3) + ; + ; If results missing reference ranges, use values from file #60. + I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D + . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)) + . S $P(LA7X,"!",2)=$P(LA7Y,"^") + . S $P(LA7X,"!",3)=$P(LA7Y,"^",2) + . S $P(LA7X,"!",11)=$P(LA7Y,"^",6) + . S $P(LA7X,"!",12)=$P(LA7Y,"^",7) + ; Use therapeutic low/high if low/high missing. + I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D + . S $P(LA7X,"!",2)=$P(LA7X,"!",11) + . S $P(LA7X,"!",3)=$P(LA7X,"!",12) + ; + ; Evaluate low/high reference ranges in case M code in these fields. + S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99 + F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D + . S @("X="_$P(LA7X,"!",LA7I)) + . S $P(LA7X,"!",LA7I)=X + ; + ; Put units/reference ranges back in variable LA7VAL + S $P(LA7VAL,"^",5)=LA7X + ; + ; Initialize OBX segment + S LA7OBX(0)="OBX" + S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN) + ; + ; Value type + ; If result is "cancel" or "comment" then data type is ST - string data + S LA7X=$S("canccomment"[$P(LA7VAL,"^"):1,1:0) + I LA7X S LA7OBX(2)="ST" + E S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB) + ; + ; Observation identifer + ; build alternate code based on dataname from file #63 in case it's needed + S LA7X=$P(LA7VAL,"^",3) + S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63" + S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH) + ; + ; Test value + ; If DoD and "canc" then report "PL Cancelled" per Lab Interop ICD. + S LA7X=$P(LA7VAL,"^") + I LA7X'="canc",$$GET1^DID(63.04,LRSB,"","TYPE","","LA7ERR")="SET" D + . S LA7X=$$EXTERNAL^DILFD(63.04,LRSB,"",LA7X) + . I LA7X="" S LA7X=$P(LA7VAL,"^") + I $G(LA7NVAF)=1,LA7X="canc" S LA7X="PL Cancelled" + S LA7OBX(5)=$$OBX5^LA7VOBX(LA7X,LA7OBX(2),LA7FS,LA7ECH) + ; + ; Units + S LA7X=$P(LA7VAL,"^",5) + S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH) + ; + ; Reference range + S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH) + ; + ; Abnormal flags + S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,"^",2)) + ; + ; "P"artial or "F"inal results + S LA7X=$S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F") + I LA7RS="C" S LA7X=LA7RS + S LA7OBX(11)=$$OBX11^LA7VOBX(LA7X) + ; + ; Observation date/time - collection date/time per HL7 standard + I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^")) + ; + S LA7DIV=$P(LA7VAL,"^",9) + I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0)) + ; + ; Facility that performed the testing + S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH) + ; + ; Person that verified the test + S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH) + ; + ; Observation method + S LA7X=$P($P(LA7VAL,"^",3),"!",4) + I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH) + ; + ; Equipment entity identifier + I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH) + ; + D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS) + ; + Q