BLRRLMUC ;IHS/MSC/MKK - Reference Lab Meaningful Use Chemistry utilities ; 25-Nov-2014 15:00 ; MKK
;;5.2;IHS LABORATORY;**1033,1034**;NOV 1, 1997;Build 88
;
LABSTOR(LRDFN,LRSS,LRIDT) ; Store INCOMING HL7 data into the Lab Data file
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRDFN,LRDL,LRIDT,LRSS,LRTS,U,XPARSYS,XQXFLG)
;
S LRUID=$G(^LR(LRDFN,LRSS,LRIDT,"ORU")) ; Get UID -- It can begin with zero
Q:$L(LRUID)<1
;
S PIEN=$$SHL7SEGS^BLRRLMUU(LRUID) ; Store HL7 data in ^TMP
;
; For non-incoming "CH" tests, store Date/Time at Test Level
I PIEN<1,LRSS="CH",$L($G(LRDL)) D
. S DATANAME=+$$GET1^DIQ(60,+LRTS,400,"I")
. Q:DATANAME<1!($G(^LR(LRDFN,LRSS,LRIDT,DATANAME))="")
. S:DATANAME ^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS")=$H
;
Q:PIEN<1
;
S $P(^LR(LRDFN,LRSS,LRIDT,"HL7"),"^")=PIEN ; Store 62.49 IEN
;
; Store the various HL7 segments' data
S SEG=0
F S SEG=$O(^TMP("BLRRLMUU",$J,LRUID,SEG)) Q:SEG="" D
. S SEGNAME=""
. F S SEGNAME=$O(^TMP("BLRRLMUU",$J,LRUID,SEG,SEGNAME)) Q:SEGNAME="" D
.. Q:$L($T(@($$VALID(SEGNAME))))<1 ; IHS/MSC/MKK - LR*5.2*1034
.. Q:$L($T(@SEGNAME))<1 ; Skip if Segment Processing Line Label does NOT exist
.. ;
.. S SEGIEN=0
.. F S SEGIEN=$O(^TMP("BLRRLMUU",$J,LRUID,SEG,SEGNAME,SEGIEN)) Q:SEGIEN="" D @SEGNAME
;
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
; Only alphabetical characters allowed.
VALID(SEGNAME) ; EP
NEW CHAR,NEWSEGN
;
S NEWSEGN=SEGNAME
F CHAR=32:1:47 S NEWSEGN=$TR(NEWSEGN,$C(CHAR))
F CHAR=58:1:64 S NEWSEGN=$TR(NEWSEGN,$C(CHAR))
F CHAR=91:1:96 S NEWSEGN=$TR(NEWSEGN,$C(CHAR))
F CHAR=123:1:126 S NEWSEGN=$TR(NEWSEGN,$C(CHAR))
Q NEWSEGN
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
MSH ; EP - Don't process anything in the MSH Segment
Q
;
PID ; EP - Don't process anything in the PID Segment
Q
;
OBR ; EP
NEW CHNGDTT,DATANAME,DNDTT,F60IEN,OBRIEN,OBSDTT,RCTOSTR,STR,TESTNAME,TSTLOINC
;
S STR=$G(^LAHM(62.49,PIEN,150,SEGIEN,0))
;
S TSTLOINC=$P($P(STR,"|",5),"^")
S TESTNAME=$P($P(STR,"|",5),"^",2)
;
S F60IEN=+$$FIND1^DIC(60,,,TESTNAME_",")
Q:F60IEN<1
;
S DATANAME=+$$GET1^DIQ(60,F60IEN,400,"I")
Q:DATANAME<1
;
Q:$L($G(^LR(LRDFN,LRSS,LRIDT,DATANAME)))<1 ; Quit if no DataName data
;
S OBSDTT=$P($P(STR,"|",8),"^") ; Observation Date/Time
S:$L(OBSDTT) OBSDTT=$$HL7TFM^XLFDT(OBSDTT)
;
S CHNGDTT=$P($P(STR,"|",23),"^") ; Status/Result Change Date/Time
S:$L(CHNGDTT) CHNGDTT=$$HL7TFM^XLFDT(CHNGDTT)
;
S DNDTT=$S($L(CHNGDTT):CHNGDTT,1:OBSDTT) ; DataName Date/Time
S:$L(DNDTT) $P(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^")=DNDTT
;
S RCTOSTR=$P(STR,"|",29) ; Result Copies To
I $L(RCTOSTR) D
. S SUBSTR2=$TR($P(RCTOSTR,"^",1,6),"^"," ")
. Q:$L($TR(SUBSTR2," "))<1 ; If only spaces, skip
. ;
. S SUBSTR2=$P(SUBSTR2," ")_","_$P(SUBSTR2," ",2,$L(SUBSTR2," "))
. S $P(^LR(LRDFN,LRSS,LRIDT,"IHS"),"^",2)=SUBSTR2
;
Q
;
OBX ; EP
NEW ANSDTT,DATANAME,F60IEN,OBRIEN,REFLAB,RLPTR,STATUS,STR,TESTNAME,TSTLOINC
NEW ADDRESS,ADDRL1,ADDRL2,CITY,COUNTY,COUNTRY,ERRS,FDA,HOSPITAL,ICOUNTRY,IENS,MDID,MDNAME,PERFHMDS,STATE,ZIPCODE
;
S STR=$G(^LAHM(62.49,PIEN,150,SEGIEN,0))
;
S RLPTR=$P($P(STR,"|",24),"^",10)
I $L(RLPTR) D
. S REFLAB=+$$FIND1^DIC(4,,,RLPTR,"D")
. S:REFLAB ^LR(LRDFN,LRSS,LRIDT,"RF")=REFLAB
;
S TSTLOINC=$P($P(STR,"|",4),"^")
S TESTNAME=$P($P(STR,"|",4),"^",2)
;
S F60IEN=+$$FIND1^DIC(60,,,TESTNAME)
S:F60IEN<1 F60IEN=++$$FIND1^DIC(60,,,TSTLOINC)
Q:F60IEN<1
;
S DATANAME=+$$GET1^DIQ(60,F60IEN,400,"I")
Q:DATANAME<1
;
Q:$L($G(^LR(LRDFN,LRSS,LRIDT,DATANAME)))<1 ; Quit if no DataName data
;
S ANSDTT=$P($P(STR,"|",15),"^") ; Analysis Date/Time
I $L(ANSDTT) D
. S ANSDTT=$$HL7TFM^XLFDT(ANSDTT)
. S $P(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^")=ANSDTT
;
S STATUS=$P(STR,"|",12)
S:$L(STATUS) $P(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^",2)=STATUS
;
S:$L(TSTLOINC) $P(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^",3)=TSTLOINC
;
S IENS=LRIDT_","_LRDFN_","
;
; Performing Hospital
S HOSPITAL=$P(STR,"|",24)
S ADDRESS=$P(STR,"|",25)
S ADDRL1=$P(ADDRESS,"^"),ADDRL2=$P(ADDRESS,"^",2)
S CITY=$P(ADDRESS,"^",3),STATE=$P(ADDRESS,"^",4),ZIPCODE=$P(ADDRESS,"^",5)
S COUNTY=$P(ADDRESS,"^",5),COUNTRY=$P(ADDRESS,"^",6)
;
; Performing Provider?
S PERFHMDS=$P(STR,"|",26)
S MDID=$P(PERFHMDS,"^")
S MDNAME=$$TRIM^XLFSTR($P(PERFHMDS,"^",2)_","_$P(PERFHMDS,"^",3)_" "_$P(PERFHMDS,"^",4),"LR"," ")
;
; Get IEN into COUNTRY CODE (#779.004) file
S ICOUNTRY=0
I $L(COUNTRY) D
. D FIND^DIC(779.004,,,,COUNTRY,,,,,"TARGET","ERRS")
. S ICOUNTRY=+$O(TARGET("DILIST",2,0))
;
Q:$L(COUNTY)<1&(ICOUNTRY<1)
;
K FDA
S:$L(COUNTY) FDA(63.04,IENS,9999996)=COUNTY
S:ICOUNTRY FDA(63.04,IENS,9999997)=ICOUNTRY
D UPDATE^DIE(,"FDA","IENS","ERRS")
;
Q
;
ORC ; EP - Don't process anything in the PID Segment
Q
;
SPM ; EP
NEW CONDSPEC,SPMIEN,STR
;
S STR=$G(^LAHM(62.49,PIEN,150,SEGIEN,0))
;
S CONDSPEC=$P($P(STR,"|",25),"^") ; SPECIMEN CONDITION
S:$L(CONDSPEC) $P(^LR(LRDFN,LRSS,LRIDT,"IHS"),"^")=CONDSPEC
;
Q
;
NTE ; EP - Don't process anything in the NTE Segment
Q
;
PV1 ; EP - Don't process anything in the PV1 Segment
Q
;
TQ1 ; EP - Don't process anything in the TQ1 Segment
Q
;
BLRLA7FX ; Fix for Lab Data MU2 Errors
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S LRDFN=.9999999
F S LR=$O(^LR(LRDFN)) Q:LRDFN<1 D
. S LRIDT=0
. F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1 D
.. S LRDN=1
.. F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
... Q:$L($G(^LR(LRDFN,"CH",LRIDT,LRDN)))
... ;
... ; There exist sub-node(s) of LRDN, but no data on LRDN. Delete the "IHS" sub-node(s).
... K ^LR(LRDFN,"CH",LRIDT,LRDN,"IHS")
;
Q
BLRRLMUC ;IHS/MSC/MKK - Reference Lab Meaningful Use Chemistry utilities ; 25-Nov-2014 15:00 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033,1034**;NOV 1, 1997;Build 88
+2 ;
LABSTOR(LRDFN,LRSS,LRIDT) ; Store INCOMING HL7 data into the Lab Data file
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRDFN,LRDL,LRIDT,LRSS,LRTS,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Get UID -- It can begin with zero
SET LRUID=$GET(^LR(LRDFN,LRSS,LRIDT,"ORU"))
+4 IF $LENGTH(LRUID)<1
QUIT
+5 ;
+6 ; Store HL7 data in ^TMP
SET PIEN=$$SHL7SEGS^BLRRLMUU(LRUID)
+7 ;
+8 ; For non-incoming "CH" tests, store Date/Time at Test Level
+9 IF PIEN<1
IF LRSS="CH"
IF $LENGTH($GET(LRDL))
Begin DoDot:1
+10 SET DATANAME=+$$GET1^DIQ(60,+LRTS,400,"I")
+11 IF DATANAME<1!($GET(^LR(LRDFN,LRSS,LRIDT,DATANAME))="")
QUIT
+12 IF DATANAME
SET ^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS")=$HOROLOG
End DoDot:1
+13 ;
+14 IF PIEN<1
QUIT
+15 ;
+16 ; Store 62.49 IEN
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,"HL7"),"^")=PIEN
+17 ;
+18 ; Store the various HL7 segments' data
+19 SET SEG=0
+20 FOR
SET SEG=$ORDER(^TMP("BLRRLMUU",$JOB,LRUID,SEG))
IF SEG=""
QUIT
Begin DoDot:1
+21 SET SEGNAME=""
+22 FOR
SET SEGNAME=$ORDER(^TMP("BLRRLMUU",$JOB,LRUID,SEG,SEGNAME))
IF SEGNAME=""
QUIT
Begin DoDot:2
+23 ; IHS/MSC/MKK - LR*5.2*1034
IF $LENGTH($TEXT(@($$VALID(SEGNAME))))<1
QUIT
+24 ; Skip if Segment Processing Line Label does NOT exist
IF $LENGTH($TEXT(@SEGNAME))<1
QUIT
+25 ;
+26 SET SEGIEN=0
+27 FOR
SET SEGIEN=$ORDER(^TMP("BLRRLMUU",$JOB,LRUID,SEG,SEGNAME,SEGIEN))
IF SEGIEN=""
QUIT
DO @SEGNAME
End DoDot:2
End DoDot:1
+28 ;
+29 QUIT
+30 ;
+31 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+32 ; Only alphabetical characters allowed.
VALID(SEGNAME) ; EP
+1 NEW CHAR,NEWSEGN
+2 ;
+3 SET NEWSEGN=SEGNAME
+4 FOR CHAR=32:1:47
SET NEWSEGN=$TRANSLATE(NEWSEGN,$CHAR(CHAR))
+5 FOR CHAR=58:1:64
SET NEWSEGN=$TRANSLATE(NEWSEGN,$CHAR(CHAR))
+6 FOR CHAR=91:1:96
SET NEWSEGN=$TRANSLATE(NEWSEGN,$CHAR(CHAR))
+7 FOR CHAR=123:1:126
SET NEWSEGN=$TRANSLATE(NEWSEGN,$CHAR(CHAR))
+8 QUIT NEWSEGN
+9 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+10 ;
MSH ; EP - Don't process anything in the MSH Segment
+1 QUIT
+2 ;
PID ; EP - Don't process anything in the PID Segment
+1 QUIT
+2 ;
OBR ; EP
+1 NEW CHNGDTT,DATANAME,DNDTT,F60IEN,OBRIEN,OBSDTT,RCTOSTR,STR,TESTNAME,TSTLOINC
+2 ;
+3 SET STR=$GET(^LAHM(62.49,PIEN,150,SEGIEN,0))
+4 ;
+5 SET TSTLOINC=$PIECE($PIECE(STR,"|",5),"^")
+6 SET TESTNAME=$PIECE($PIECE(STR,"|",5),"^",2)
+7 ;
+8 SET F60IEN=+$$FIND1^DIC(60,,,TESTNAME_",")
+9 IF F60IEN<1
QUIT
+10 ;
+11 SET DATANAME=+$$GET1^DIQ(60,F60IEN,400,"I")
+12 IF DATANAME<1
QUIT
+13 ;
+14 ; Quit if no DataName data
IF $LENGTH($GET(^LR(LRDFN,LRSS,LRIDT,DATANAME)))<1
QUIT
+15 ;
+16 ; Observation Date/Time
SET OBSDTT=$PIECE($PIECE(STR,"|",8),"^")
+17 IF $LENGTH(OBSDTT)
SET OBSDTT=$$HL7TFM^XLFDT(OBSDTT)
+18 ;
+19 ; Status/Result Change Date/Time
SET CHNGDTT=$PIECE($PIECE(STR,"|",23),"^")
+20 IF $LENGTH(CHNGDTT)
SET CHNGDTT=$$HL7TFM^XLFDT(CHNGDTT)
+21 ;
+22 ; DataName Date/Time
SET DNDTT=$SELECT($LENGTH(CHNGDTT):CHNGDTT,1:OBSDTT)
+23 IF $LENGTH(DNDTT)
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^")=DNDTT
+24 ;
+25 ; Result Copies To
SET RCTOSTR=$PIECE(STR,"|",29)
+26 IF $LENGTH(RCTOSTR)
Begin DoDot:1
+27 SET SUBSTR2=$TRANSLATE($PIECE(RCTOSTR,"^",1,6),"^"," ")
+28 ; If only spaces, skip
IF $LENGTH($TRANSLATE(SUBSTR2," "))<1
QUIT
+29 ;
+30 SET SUBSTR2=$PIECE(SUBSTR2," ")_","_$PIECE(SUBSTR2," ",2,$LENGTH(SUBSTR2," "))
+31 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,"IHS"),"^",2)=SUBSTR2
End DoDot:1
+32 ;
+33 QUIT
+34 ;
OBX ; EP
+1 NEW ANSDTT,DATANAME,F60IEN,OBRIEN,REFLAB,RLPTR,STATUS,STR,TESTNAME,TSTLOINC
+2 NEW ADDRESS,ADDRL1,ADDRL2,CITY,COUNTY,COUNTRY,ERRS,FDA,HOSPITAL,ICOUNTRY,IENS,MDID,MDNAME,PERFHMDS,STATE,ZIPCODE
+3 ;
+4 SET STR=$GET(^LAHM(62.49,PIEN,150,SEGIEN,0))
+5 ;
+6 SET RLPTR=$PIECE($PIECE(STR,"|",24),"^",10)
+7 IF $LENGTH(RLPTR)
Begin DoDot:1
+8 SET REFLAB=+$$FIND1^DIC(4,,,RLPTR,"D")
+9 IF REFLAB
SET ^LR(LRDFN,LRSS,LRIDT,"RF")=REFLAB
End DoDot:1
+10 ;
+11 SET TSTLOINC=$PIECE($PIECE(STR,"|",4),"^")
+12 SET TESTNAME=$PIECE($PIECE(STR,"|",4),"^",2)
+13 ;
+14 SET F60IEN=+$$FIND1^DIC(60,,,TESTNAME)
+15 IF F60IEN<1
SET F60IEN=++$$FIND1^DIC(60,,,TSTLOINC)
+16 IF F60IEN<1
QUIT
+17 ;
+18 SET DATANAME=+$$GET1^DIQ(60,F60IEN,400,"I")
+19 IF DATANAME<1
QUIT
+20 ;
+21 ; Quit if no DataName data
IF $LENGTH($GET(^LR(LRDFN,LRSS,LRIDT,DATANAME)))<1
QUIT
+22 ;
+23 ; Analysis Date/Time
SET ANSDTT=$PIECE($PIECE(STR,"|",15),"^")
+24 IF $LENGTH(ANSDTT)
Begin DoDot:1
+25 SET ANSDTT=$$HL7TFM^XLFDT(ANSDTT)
+26 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^")=ANSDTT
End DoDot:1
+27 ;
+28 SET STATUS=$PIECE(STR,"|",12)
+29 IF $LENGTH(STATUS)
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^",2)=STATUS
+30 ;
+31 IF $LENGTH(TSTLOINC)
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^",3)=TSTLOINC
+32 ;
+33 SET IENS=LRIDT_","_LRDFN_","
+34 ;
+35 ; Performing Hospital
+36 SET HOSPITAL=$PIECE(STR,"|",24)
+37 SET ADDRESS=$PIECE(STR,"|",25)
+38 SET ADDRL1=$PIECE(ADDRESS,"^")
SET ADDRL2=$PIECE(ADDRESS,"^",2)
+39 SET CITY=$PIECE(ADDRESS,"^",3)
SET STATE=$PIECE(ADDRESS,"^",4)
SET ZIPCODE=$PIECE(ADDRESS,"^",5)
+40 SET COUNTY=$PIECE(ADDRESS,"^",5)
SET COUNTRY=$PIECE(ADDRESS,"^",6)
+41 ;
+42 ; Performing Provider?
+43 SET PERFHMDS=$PIECE(STR,"|",26)
+44 SET MDID=$PIECE(PERFHMDS,"^")
+45 SET MDNAME=$$TRIM^XLFSTR($PIECE(PERFHMDS,"^",2)_","_$PIECE(PERFHMDS,"^",3)_" "_$PIECE(PERFHMDS,"^",4),"LR"," ")
+46 ;
+47 ; Get IEN into COUNTRY CODE (#779.004) file
+48 SET ICOUNTRY=0
+49 IF $LENGTH(COUNTRY)
Begin DoDot:1
+50 DO FIND^DIC(779.004,,,,COUNTRY,,,,,"TARGET","ERRS")
+51 SET ICOUNTRY=+$ORDER(TARGET("DILIST",2,0))
End DoDot:1
+52 ;
+53 IF $LENGTH(COUNTY)<1&(ICOUNTRY<1)
QUIT
+54 ;
+55 KILL FDA
+56 IF $LENGTH(COUNTY)
SET FDA(63.04,IENS,9999996)=COUNTY
+57 IF ICOUNTRY
SET FDA(63.04,IENS,9999997)=ICOUNTRY
+58 DO UPDATE^DIE(,"FDA","IENS","ERRS")
+59 ;
+60 QUIT
+61 ;
ORC ; EP - Don't process anything in the PID Segment
+1 QUIT
+2 ;
SPM ; EP
+1 NEW CONDSPEC,SPMIEN,STR
+2 ;
+3 SET STR=$GET(^LAHM(62.49,PIEN,150,SEGIEN,0))
+4 ;
+5 ; SPECIMEN CONDITION
SET CONDSPEC=$PIECE($PIECE(STR,"|",25),"^")
+6 IF $LENGTH(CONDSPEC)
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,"IHS"),"^")=CONDSPEC
+7 ;
+8 QUIT
+9 ;
NTE ; EP - Don't process anything in the NTE Segment
+1 QUIT
+2 ;
PV1 ; EP - Don't process anything in the PV1 Segment
+1 QUIT
+2 ;
TQ1 ; EP - Don't process anything in the TQ1 Segment
+1 QUIT
+2 ;
BLRLA7FX ; Fix for Lab Data MU2 Errors
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET LRDFN=.9999999
+4 FOR
SET LR=$ORDER(^LR(LRDFN))
IF LRDFN<1
QUIT
Begin DoDot:1
+5 SET LRIDT=0
+6 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
IF LRIDT<1
QUIT
Begin DoDot:2
+7 SET LRDN=1
+8 FOR
SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
IF LRDN<1
QUIT
Begin DoDot:3
+9 IF $LENGTH($GET(^LR(LRDFN,"CH",LRIDT,LRDN)))
QUIT
+10 ;
+11 ; There exist sub-node(s) of LRDN, but no data on LRDN. Delete the "IHS" sub-node(s).
+12 KILL ^LR(LRDFN,"CH",LRIDT,LRDN,"IHS")
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
+14 QUIT
