Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRRLMUC

BLRRLMUC.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. 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)
  1.  ;
  1.  S LRUID=$G(^LR(LRDFN,LRSS,LRIDT,"ORU"))           ; Get UID -- It can begin with zero
  1.  Q:$L(LRUID)<1
  1.  ;
  1.  S PIEN=$$SHL7SEGS^BLRRLMUU(LRUID)                 ; Store HL7 data in ^TMP
  1.  ;
  1.  ; For non-incoming "CH" tests, store Date/Time at Test Level
  1.  I PIEN<1,LRSS="CH",$L($G(LRDL)) D
  1.  . S DATANAME=+$$GET1^DIQ(60,+LRTS,400,"I")
  1.  . Q:DATANAME<1!($G(^LR(LRDFN,LRSS,LRIDT,DATANAME))="")
  1.  . S:DATANAME ^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS")=$H
  1.  ;
  1.  Q:PIEN<1
  1.  ;
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,"HL7"),"^")=PIEN        ; Store 62.49 IEN
  1.  ;
  1.  ; Store the various HL7 segments' data
  1.  S SEG=0
  1.  F  S SEG=$O(^TMP("BLRRLMUU",$J,LRUID,SEG))  Q:SEG=""  D
  1.  . S SEGNAME=""
  1.  . F  S SEGNAME=$O(^TMP("BLRRLMUU",$J,LRUID,SEG,SEGNAME))  Q:SEGNAME=""  D
  1.  .. Q:$L($T(@($$VALID(SEGNAME))))<1     ; IHS/MSC/MKK - LR*5.2*1034
  1.  .. Q:$L($T(@SEGNAME))<1  ; Skip if Segment Processing Line Label does NOT exist
  1.  .. ;
  1.  .. S SEGIEN=0
  1.  .. F  S SEGIEN=$O(^TMP("BLRRLMUU",$J,LRUID,SEG,SEGNAME,SEGIEN))  Q:SEGIEN=""  D @SEGNAME
  1.  ;
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1.  ; Only alphabetical characters allowed.
  1. VALID(SEGNAME) ; EP 
  1.  NEW CHAR,NEWSEGN
  1.  ;
  1.  S NEWSEGN=SEGNAME
  1.  F CHAR=32:1:47  S NEWSEGN=$TR(NEWSEGN,$C(CHAR))
  1.  F CHAR=58:1:64  S NEWSEGN=$TR(NEWSEGN,$C(CHAR))
  1.  F CHAR=91:1:96  S NEWSEGN=$TR(NEWSEGN,$C(CHAR))
  1.  F CHAR=123:1:126  S NEWSEGN=$TR(NEWSEGN,$C(CHAR))
  1.  Q NEWSEGN
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1. MSH ; EP - Don't process anything in the MSH Segment
  1.  Q
  1.  ;
  1. PID ; EP - Don't process anything in the PID Segment
  1.  Q
  1.  ;
  1. OBR ; EP
  1.  NEW CHNGDTT,DATANAME,DNDTT,F60IEN,OBRIEN,OBSDTT,RCTOSTR,STR,TESTNAME,TSTLOINC
  1.  ;
  1.  S STR=$G(^LAHM(62.49,PIEN,150,SEGIEN,0))
  1.  ;
  1.  S TSTLOINC=$P($P(STR,"|",5),"^")
  1.  S TESTNAME=$P($P(STR,"|",5),"^",2)
  1.  ;
  1.  S F60IEN=+$$FIND1^DIC(60,,,TESTNAME_",")
  1.  Q:F60IEN<1
  1.  ;
  1.  S DATANAME=+$$GET1^DIQ(60,F60IEN,400,"I")
  1.  Q:DATANAME<1
  1.  ;
  1.  Q:$L($G(^LR(LRDFN,LRSS,LRIDT,DATANAME)))<1   ; Quit if no DataName data
  1.  ;
  1.  S OBSDTT=$P($P(STR,"|",8),"^")               ; Observation Date/Time
  1.  S:$L(OBSDTT) OBSDTT=$$HL7TFM^XLFDT(OBSDTT)
  1.  ;
  1.  S CHNGDTT=$P($P(STR,"|",23),"^")             ; Status/Result Change Date/Time
  1.  S:$L(CHNGDTT) CHNGDTT=$$HL7TFM^XLFDT(CHNGDTT)
  1.  ;
  1.  S DNDTT=$S($L(CHNGDTT):CHNGDTT,1:OBSDTT)     ; DataName Date/Time
  1.  S:$L(DNDTT) $P(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^")=DNDTT
  1.  ;
  1.  S RCTOSTR=$P(STR,"|",29)                     ; Result Copies To
  1.  I $L(RCTOSTR) D
  1.  . S SUBSTR2=$TR($P(RCTOSTR,"^",1,6),"^"," ")
  1.  . Q:$L($TR(SUBSTR2," "))<1                   ; If only spaces, skip
  1.  . ;
  1.  . S SUBSTR2=$P(SUBSTR2," ")_","_$P(SUBSTR2," ",2,$L(SUBSTR2," "))
  1.  . S $P(^LR(LRDFN,LRSS,LRIDT,"IHS"),"^",2)=SUBSTR2
  1.  ;
  1.  Q
  1.  ;
  1. OBX ; EP
  1.  NEW ANSDTT,DATANAME,F60IEN,OBRIEN,REFLAB,RLPTR,STATUS,STR,TESTNAME,TSTLOINC
  1.  NEW ADDRESS,ADDRL1,ADDRL2,CITY,COUNTY,COUNTRY,ERRS,FDA,HOSPITAL,ICOUNTRY,IENS,MDID,MDNAME,PERFHMDS,STATE,ZIPCODE
  1.  ;
  1.  S STR=$G(^LAHM(62.49,PIEN,150,SEGIEN,0))
  1.  ;
  1.  S RLPTR=$P($P(STR,"|",24),"^",10)
  1.  I $L(RLPTR) D
  1.  . S REFLAB=+$$FIND1^DIC(4,,,RLPTR,"D")
  1.  . S:REFLAB ^LR(LRDFN,LRSS,LRIDT,"RF")=REFLAB
  1.  ;
  1.  S TSTLOINC=$P($P(STR,"|",4),"^")
  1.  S TESTNAME=$P($P(STR,"|",4),"^",2)
  1.  ;
  1.  S F60IEN=+$$FIND1^DIC(60,,,TESTNAME)
  1.  S:F60IEN<1 F60IEN=++$$FIND1^DIC(60,,,TSTLOINC)
  1.  Q:F60IEN<1
  1.  ;
  1.  S DATANAME=+$$GET1^DIQ(60,F60IEN,400,"I")
  1.  Q:DATANAME<1
  1.  ;
  1.  Q:$L($G(^LR(LRDFN,LRSS,LRIDT,DATANAME)))<1    ; Quit if no DataName data
  1.  ;
  1.  S ANSDTT=$P($P(STR,"|",15),"^")               ; Analysis Date/Time
  1.  I $L(ANSDTT) D
  1.  . S ANSDTT=$$HL7TFM^XLFDT(ANSDTT)
  1.  . S $P(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^")=ANSDTT
  1.  ;
  1.  S STATUS=$P(STR,"|",12)
  1.  S:$L(STATUS) $P(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^",2)=STATUS
  1.  ;
  1.  S:$L(TSTLOINC) $P(^LR(LRDFN,LRSS,LRIDT,DATANAME,"IHS"),"^",3)=TSTLOINC
  1.  ;
  1.  S IENS=LRIDT_","_LRDFN_","
  1.  ;
  1.  ; Performing Hospital
  1.  S HOSPITAL=$P(STR,"|",24)
  1.  S ADDRESS=$P(STR,"|",25)
  1.  S ADDRL1=$P(ADDRESS,"^"),ADDRL2=$P(ADDRESS,"^",2)
  1.  S CITY=$P(ADDRESS,"^",3),STATE=$P(ADDRESS,"^",4),ZIPCODE=$P(ADDRESS,"^",5)
  1.  S COUNTY=$P(ADDRESS,"^",5),COUNTRY=$P(ADDRESS,"^",6)
  1.  ;
  1.  ; Performing Provider?
  1.  S PERFHMDS=$P(STR,"|",26)
  1.  S MDID=$P(PERFHMDS,"^")
  1.  S MDNAME=$$TRIM^XLFSTR($P(PERFHMDS,"^",2)_","_$P(PERFHMDS,"^",3)_" "_$P(PERFHMDS,"^",4),"LR"," ")
  1.  ;
  1.  ; Get IEN into COUNTRY CODE (#779.004) file
  1.  S ICOUNTRY=0
  1.  I $L(COUNTRY) D
  1.  . D FIND^DIC(779.004,,,,COUNTRY,,,,,"TARGET","ERRS")
  1.  . S ICOUNTRY=+$O(TARGET("DILIST",2,0))
  1.  ;
  1.  Q:$L(COUNTY)<1&(ICOUNTRY<1)
  1.  ;
  1.  K FDA
  1.  S:$L(COUNTY) FDA(63.04,IENS,9999996)=COUNTY
  1.  S:ICOUNTRY FDA(63.04,IENS,9999997)=ICOUNTRY
  1.  D UPDATE^DIE(,"FDA","IENS","ERRS")
  1.  ;
  1.  Q
  1.  ;
  1. ORC ; EP - Don't process anything in the PID Segment
  1.  Q
  1.  ;
  1. SPM ; EP
  1.  NEW CONDSPEC,SPMIEN,STR
  1.  ;
  1.  S STR=$G(^LAHM(62.49,PIEN,150,SEGIEN,0))
  1.  ;
  1.  S CONDSPEC=$P($P(STR,"|",25),"^")            ; SPECIMEN CONDITION
  1.  S:$L(CONDSPEC) $P(^LR(LRDFN,LRSS,LRIDT,"IHS"),"^")=CONDSPEC
  1.  ;
  1.  Q
  1.  ;
  1. NTE ; EP - Don't process anything in the NTE Segment
  1.  Q
  1.  ;
  1. PV1 ; EP - Don't process anything in the PV1 Segment
  1.  Q
  1.  ;
  1. TQ1 ; EP - Don't process anything in the TQ1 Segment
  1.  Q
  1.  ;
  1. 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)
  1.  ;
  1.  S LRDFN=.9999999
  1.  F  S LR=$O(^LR(LRDFN))  Q:LRDFN<1  D
  1.  . S LRIDT=0
  1.  . F  S LRIDT=$O(^LR(LRDFN,"CH",LRIDT))  Q:LRIDT<1  D
  1.  .. S LRDN=1
  1.  .. F  S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN))  Q:LRDN<1  D
  1.  ... Q:$L($G(^LR(LRDFN,"CH",LRIDT,LRDN)))
  1.  ... ;
  1.  ... ; There exist sub-node(s) of LRDN, but no data on LRDN.  Delete the "IHS" sub-node(s).
  1.  ... K ^LR(LRDFN,"CH",LRIDT,LRDN,"IHS")
  1.  ;
  1.  Q