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

BHLRLABU.m

Go to the documentation of this file. 
  1. BHLRLABU ;cmi/sitka/maw - BHL ORU/R01 Ref Lab inbound Lab Message  [ 04/24/2003  2:24 PM ] ; 19 Mar 2004  2:24 PM
  1.  ;;3.01;BHL IHS Interfaces with GIS;**13,14,16**;JUL 01, 2001
  1.  ;
  1.  ;UNILAB INBOUND
  1.  ;
  1.  ;this routine will file the inbound unilab lab message.
  1.  ;9/28/2004 cmi/anch/maw added collection date and accession # to BUL
  1.  ;10/1/2004 cmi/anch/maw added collection date and accession # to SNDBUL
  1.  ;
  1. MAIN ;EP -- this is the main routine driver
  1.  S BHLNOST=1 D ^BHLSETI
  1.  S BHLRL=+$G(^BLRSITE(DUZ(2),"RL"))
  1.  Q:'$G(BHLRL)
  1.  ;I '$P($G(^BLRRL(BHLRL,0)),U,10) D ORU^BLRHL7(BHLUIF),EOJ Q  2/25/2008 cmi/maw orig
  1.  I '$P($G(^BLRSITE(DUZ(2),"RL")),U,18) D ORU^BLRHL7(BHLUIF),EOJ Q  ;NEW cmi/maw 2/25/2008
  1.  D ^BHLFO
  1.  D MSH
  1.  D CHKPAT
  1.  I $D(BHLERR("FATAL")) D  Q
  1.  . D SNDBUL(BHLUIF,PAT,BHLNM,BHLDOB,BHLSEX)
  1.  K BHLSAF
  1.  D PRS
  1.  D RFL
  1.  D EOJ
  1.  D JOB^BLRPARAM  ;jump start the link
  1.  Q
  1.  ;
  1. MSH ;-- get data out of MSH
  1.  S BHLDUZ2=DUZ(2)
  1.  S BHLACT=BHLRAF
  1.  I $G(BHLACT) S BHLDUZ2=$O(^BLRSITE("ACCT",BHLACT,0))  ;cmi/flag/maw 11/17/2003 now looking in BLR Master Control File
  1.  I '$G(BHLDUZ2) S BHLDUZ2=DUZ(2)
  1.  ;I BHLACT=4107080 S BHLDUZ2=4618
  1.  Q
  1.  ;
  1. CHKPAT ;-- lookup the patient by chart
  1.  N BHLR
  1.  S BHLR="PID"
  1.  S BHLDA=0,BHLDA=$O(@BHLTMP@(BHLDA)) ;should be one PID
  1.  S PAT=+$G(@BHLTMP@(BHLDA,3))
  1.  S BHLNM=$G(@BHLTMP@(BHLDA,5))
  1.  S BHLDOB=$$HDATE^INHUT($E($G(@BHLTMP@(BHLDA,7)),1,8))
  1.  S BHLSEX=$G(@BHLTMP@(BHLDA,8))
  1.  S BHLPAT=$$CHKPAT^BHLU(PAT,BHLDUZ2)
  1.  I '$G(BHLPAT) S BHLERCD="NOPAT" X BHLERR
  1.  Q:$D(BHLERR("FATAL"))
  1.  S BHLPAT=$$CHKDOB^BHLU(BHLPAT)
  1.  I '$G(BHLPAT) S BHLERCD="NOPAT" X BHLERR
  1.  Q:$D(BHLERR("FATAL"))
  1.  S BHLLOE=$G(BHLDUZ2)
  1.  ;cmi/maw added 1/7/2003
  1.  S BHLLOC=$P($G(^BLRSITE(BHLDUZ2,"RL")),U,9)
  1.  I $G(BHLLOC) S BHLLOCE=$P($G(^SC(BHLLOC,0)),U)
  1.  Q
  1.  ;
  1. PRS ;-- parse the HL7 message array     
  1.  D OBR
  1.  Q
  1.  ;
  1. OBR ;-- parse the OBR segment
  1.  N BHLR
  1.  S BHLR="OBR"
  1.  S BHLODA=0 F  S BHLODA=$O(@BHLTMP@(BHLODA)) Q:BHLODA=""!($G(BHLERR("FATAL")))  D
  1.  . K BHLPAR,BHLTST,BHLPSEQ,BHLCLTE,BHLRSLT,BHLREFR,BHLREFL,BHLREFH
  1.  . K BHLABN,BHLUNIT,BHLRESDT
  1.  . S BHLACC=$G(@BHLTMP@(BHLODA,3))
  1.  . I $G(BHLACC)="" S BHLACC=$G(@BHLTMP@(BHLODA,2))
  1.  . S BHLTST=$P($G(@BHLTMP@(BHLODA,4)),CS)
  1.  . S BHLCLTE=$P($G(@BHLTMP@(BHLODA,4)),CS,2)
  1.  . S BHLOBSDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,7)),"T")
  1.  . S BHLODT=$P(BHLOBSDT,".")  ;order date
  1.  . S BHLSPDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,14)),"T")
  1.  . S BHLORDP=$P($G(@BHLTMP@(BHLODA,16)),"^")
  1.  . S BHLRESDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,22)),"T")
  1.  . S BHLPAR=BHLODA
  1.  . D MAP("ORDER")
  1.  . I '$G(BHLCLT) D  Q  ;quit if no test match 4/16/2004
  1.  .. S BHLERR("FATAL")=1
  1.  .. D BUL
  1.  . I $D(BHL("OBX",BHLODA,2)) D CPT,FILE K BHLCPTS S BHLPSEQ=BHLSEQ
  1.  . I $G(BHLPSEQ),$D(BHL("NTE",BHLODA,1)) D NTEOBR
  1.  . I $D(BHLERR("WARNING")) D BUL
  1.  . K BHLERR("WARNING")
  1.  . D OBX
  1.  Q
  1.  ;
  1. OBX ;-- parse the OBX segment
  1.  N BHLR
  1.  S BHLR="OBX"
  1.  S BHLXDA=0 F  S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING")))  D
  1.  . K BHLSPAR,BHLTST,BHLCLTE,BHLRSLT,BHLUNIT,BHLREFR,BHLREFL,BHLREFH
  1.  . K BHLABN,BHLUNIT,BHLRESDT
  1.  . S BHLTST=$P($G(@BHLSTMP@(BHLXDA,3)),CS)
  1.  . S BHLCLTE=$P($G(@BHLSTMP@(BHLXDA,3)),CS,2)
  1.  . S BHLRSLT=$G(@BHLSTMP@(BHLXDA,5))
  1.  . S BHLUNIT=$G(@BHLSTMP@(BHLXDA,6))
  1.  . S BHLREFR=$G(@BHLSTMP@(BHLXDA,7))
  1.  . S BHLREFL=BHLREFR
  1.  . I $E(BHLREFR,1,1)?.N D
  1.  .. S BHLREFL=$P($G(BHLREFR),"-")
  1.  .. S BHLREFH=$P($G(BHLREFR),"-",2)
  1.  . S BHLABN=$G(@BHLSTMP@(BHLXDA,8))
  1.  . S BHLRESDT=$$HDATE^INHUT($G(@BHLSTMP@(BHLXDA,14)),"T")
  1.  . S BHLSPAR=BHLXDA
  1.  . D TESTMAP
  1.  . I '$G(BHLPSEQ) D CPT
  1.  . I '$G(BHLCLT) D BUL Q
  1.  . D FILE
  1.  . K BHLCPTS,BHLRSLT,BHLUNIT,BHLREFR,BHLREFL,BHLREFH
  1.  . D NTE
  1.  . K BHLCMT
  1.  . I $D(BHLERR("WARNING")) D BUL
  1.  . K BHLERR("WARNING")
  1.  Q
  1.  ;
  1. NTEOBR ;-- parse the NTE in the OBR segment
  1.  N BHLR
  1.  S BHLR="NTE"
  1.  S BHLNDA=0 F  S BHLNDA=$O(@BHLSTMP@(BHLNDA)) Q:BHLNDA=""  D
  1.  . S:'$D(BHLCMT(BHLNDA)) BHLCMT(BHLNDA)=0
  1.  . S (BHLCMT(BHLNDA),X)=$TR($G(@BHLSTMP@(BHLNDA,3)),"""","'")
  1.  . Q:$G(X)=""
  1.  . K DIC,DD,DO
  1.  . S DIC="^BLRTXLOG("_BHLPSEQ_",30,"
  1.  . S DA(1)=BHLPSEQ,DIC(0)="L",DIC("P")=$P(^DD(9009022,3001,0),"^",2)
  1.  . D FILE^DICN
  1.  K BHLCMT
  1.  Q
  1.  ;
  1. NTE ;-- parse the NTE segment
  1.  N BHLR
  1.  S BHLR="NTE"
  1.  S BHLNDA=0 F  S BHLNDA=$O(@BHLSSTMP@(BHLNDA)) Q:BHLNDA=""  D
  1.  . S:'$D(BHLCMT(BHLNDA)) BHLCMT(BHLNDA)=0
  1.  . S (BHLCMT(BHLNDA),X)=$TR($G(@BHLSSTMP@(BHLNDA,3)),"""","'") ;cmi/maw modified line 10/26/2003
  1.  . ;S (BHLCMT(BHLNDA),X)=$G(@BHLSSTMP@(BHLNDA,3))  ;cmi/maw new line 10/20/2003
  1.  . K DIC,DD,DO
  1.  . S DIC="^BLRTXLOG("_BHLSEQ_",30,"
  1.  . S DA(1)=BHLSEQ,DIC(0)="L",DIC("P")=$P(^DD(9009022,3001,0),"^",2)
  1.  . ;D ^DIC  cmi/maw 9/7/2004 old code, changed to FILE^DICN
  1.  . D FILE^DICN
  1.  Q
  1.  ;
  1. MAP(BHLTYPC) ;-- map the necessary incoming items to rpms
  1.  I $G(BHLORDP)]"" D
  1.  . S BHLORDPI=$O(^VA(200,"AUPIN",BHLORDP,0))
  1.  I '$G(BHLORDPI) D
  1.  . S BHLORDPI=$O(^VA(200,"ANPI",BHLORDP,0))
  1.  ;S BHLORDPE=$S(BHLORDP'="":$P($G(^DIC(6,BHLORDP,0)),U),1:"")
  1.  I '$G(BHLORDPI) S BHLORDPI=$O(^VA(200,"B","TECHNICIAN,LAB",0))
  1.  I $G(BHLORDPI) S BHLORDPE=$P($G(^VA(200,BHLORDPI,0)),U)
  1.  S BHLPNM=$$VAL^XBDIQ1(2,BHLPAT,.01)
  1.  S BHLLOE=$G(BHLDUZ2)
  1. TESTMAP ;
  1.  N BHLZDA
  1.  K BHLCLTI,BHLCLT
  1.  S BHLZDA=0 F  S BHLZDA=$O(^BLRRL("BTST",BHLTST,BHLRL,BHLZDA)) Q:'BHLZDA!$G(BHLCLT)  D
  1.  . I $G(BHLTYPC)]"",$P($G(^BLRRL(BHLRL,1,BHLZDA,0)),U,3) S BHLCLTI=BHLZDA,BHLCLT=$P($G(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2) Q
  1.  . I $G(BHLTYPC)="",$P($G(^BLRRL(BHLRL,1,BHLZDA,0)),U,4) S BHLCLTI=BHLZDA,BHLCLT=$P($G(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2) Q
  1.  ;S BHLCLTI=$O(^BLRRL("BTST",BHLTST,BHLRL,0))
  1.  ;I BHLCLTI="" S BHLERCD="NOLCODE" X BHLERR Q
  1.  ;S BHLCLT=$P($G(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2)
  1.  ;I $G(BHLCLT)="" S BHLERCD="NOLAB" X BHLERR
  1.  Q
  1.  ;
  1. CPT ;-- let's build the cpt string
  1.  Q:'$P($G(^BLRRL(BHLRL,0)),U,17)  ;don't pass if set to yes
  1.  Q:$G(BHLPSEQ)
  1.  Q:'$G(BHLCLT)
  1.  S BHLCTST=$O(^BLRCPT("C",BHLCLT,0))
  1.  Q:BHLCTST=""
  1.  S BHLCCNT=0
  1.  S BHLCPTS="|||||"
  1.  S BHLCDA=0 F  S BHLCDA=$O(^BLRCPT(BHLCTST,11,BHLCDA)) Q:'BHLCDA  D
  1.  . S BHLCPT=$P($G(^BLRCPT(BHLCTST,11,BHLDA,0)),U)
  1.  . S BHLCCNT=BHLCCNT+1
  1.  . S $P(BHLCPTS,"|",BHLCCNT)=$G(BHLCPT)
  1.  Q
  1.  ;
  1. FILE ;-- file the data in BLRTXLOG
  1.  ;FORMAT IS BLRVARS="FIELD NAME_VARIABLE~FIELD NAME_VARIABLE""
  1.  K BLR,BLRF,BLRFDA  ;maw test
  1.  Q:$G(BHLRSLT)="DNR"  ;don't file Do NOT REPORT results
  1.  I '$G(BHLCLT) K BHLSEQ
  1.  I $G(BHLCLTI)="" S BHLERCD="NOLCODE" X BHLERR D BUL
  1.  I $G(BHLCLT)="" S BHLERCD="NOLAB" X BHLERR D BUL Q  ;cmi/flag/maw 4/8/2004 quit if not lab match
  1.  ;cmi/anch/maw added 1/17/2006
  1.  I $G(BHLUIF) Q:$O(^BLRTXLOG("AHL7",BHLUIF_BHLCLT,0))  ;don't refile tests that are already there
  1.  ;cmi/anch/maw end 1/17/2006
  1.  S BHLQSIT=$P($G(^AUTTSITE(1,0)),U)
  1.  Q:BHLQSIT=""
  1.  S BLRPCC=$P($G(^BLRSITE(BHLQSIT,0)),U,3)
  1.  S (BLRODTM,BLRSEQ,BLRTEST1)="",BLRLINK=1,BLRERR=0,BHLPHASE="R",BLRCMF="C"
  1.  S BLRXPCC=1 ;after patch 10
  1.  S BHLSEQ=$$GETIEN^BLRFLTL(BLRODTM,BLRSEQ,BLRTEST1)
  1.  ;I $G(BHLCLT)="" S BHLERCD="NOLAB" X BHLERR Q  ;cmi/flag/maw changed this 1/22/2003
  1.  S BLRVARS="SEQUENCE NUMBER_BHLSEQ~STATUS FLAG_BHLPHASE~DUZ(2)_BHLLOE~"
  1.  S BLRVARS=BLRVARS_"PATIENT NAME_$G(BHLPNM)~PATIENT POINTER VALUE_$G(BHLPAT)~ACCESSION NUMBER_BHLACC~"
  1.  S BLRVARS=BLRVARS_"ORDERING PROVIDER NAME_$G(BHLORDPE)~ORDERING PROVIDER POINTER_$G(BHLORDPI)~"
  1.  S BLRVARS=BLRVARS_"PANEL/TEST POINTER_BHLCLT~PANEL/TEST NAME_$G(BHLCLTE)~RESULT_$G(BHLRSLT)~UNITS_$G(BHLUNIT)~REFERENCE LOW_$G(BHLREFL)~REFERENCE HIGH_$G(BHLREFH)~"
  1.  S BLRVARS=BLRVARS_"PARENT POINTER_$G(BHLPSEQ)~COLLECTION DATE/TIME_BHLOBSDT~ORDER DATE_$G(BHLOBSDT)~ENTRY DATE/TIME_$G(BHLSPDT)~ORDERING LOCATION POINTER_$G(BHLLOC)~ORDERING LOCATION NAME_$G(BHLLOCE)~"
  1.  S BHLLM="CH",BLRVARS=BLRVARS_"LAB MODULE_BHLLM~"
  1.  S BHLIO="E",BLRVARS=BLRVARS_"I/O CATEGORY_BHLIO~"
  1.  S BHLSTAT="R",BLRVARS=BLRVARS_"STATUS FLAG_BHLSTAT~"
  1.  S BHLBILL=1,BLRVARS=BLRVARS_"BILLABLE ITEM_BHLBILL~"
  1.  S BHLSRC="R",BLRVARS=BLRVARS_"SOURCE OF DATA INPUT_BHLSRC~"
  1.  S BHLSPC="",BLRVARS=BLRVARS_"SITE/SPECIMEN POINTER_BHLSPC~"
  1.  S BHLSPCE="",BLRVARS=BLRVARS_"SITE/SPECIMEN NAME_BHLSPCE~"
  1.  S BHLLFLE=2,BLRVARS=BLRVARS_"LRFILE_BHLLFLE~"
  1.  S BLRVARS=BLRVARS_"RESULT N/A FLAG_$G(BHLABN)~"
  1.  S BLRVARS=BLRVARS_"BILLING CPT STRING_$G(BHLCPTS)~"
  1.  S BLRVARS=BLRVARS_"HL7 MESSAGE IEN_$G(BHLUIF)"
  1.  I '$D(BLRF(0)) D INIT^BLRPARAM ;after patch 10
  1.  ;I '$D(BLRF(0)) D ^BLRPARAM
  1.  D SETVALS^BLRFLTL ;after patch 10
  1.  ;D ^BLRFLTL("C",BLRVARS) ;before patch 10
  1.  D ^BLRNFLTL ;after patch 10
  1.  Q
  1.  ;
  1. BUL ;-- file a bulletin if no test match
  1.  ;cmi/anch/maw added collection date and accession number
  1.  S XMB="BHL NO TEST MATCH"
  1.  S XMB(1)=$G(BHLTST),XMB(2)=$G(BHLCLTE),XMB(3)=$G(BHLSEQ),XMB(4)=$G(UIF)
  1.  S XMB(5)=$$FMTE^XLFDT(BHLOBSDT),XMB(6)=$G(BHLACC)
  1.  D ^XMB
  1.  Q
  1.  ;
  1. SNDBUL(VAR,VAR1,VAR2,VAR3,VAR4) ;-- fire a generic bulletin
  1.  S XMB="BHL REFLAB NO PAT",XMB(1)=VAR,XMB(2)=VAR1,XMB(3)=VAR2
  1.  S XMB(4)=$$FMTE^XLFDT(VAR3),XMB(5)=VAR4
  1.  ;cmi/anch/maw 10/1/2004 let's try and grab the collection date and accession number here
  1.  N VAR5,VAR6,BHLR
  1.  S BHLR="OBR"
  1.  S VAR5=$$HDATE^INHUT($G(@BHLTMP@(1,7)),"T")  ;collection date
  1.  I $G(VAR5) S VAR5=$$FMTE^XLFDT(VAR5)  ;external date format
  1.  S VAR6=$G(@BHLTMP@(1,3))  ;accession number
  1.  S XMB(6)=$G(VAR5),XMB(7)=$G(VAR6)
  1.  D ^XMB
  1.  Q
  1.  ;
  1. EOJ ;-- kill variables and quit
  1.  D EN^XBVK("BLR")
  1.  D EOJ^BHLSETI
  1.  Q
  1.  ;
  1. RFL ;-- set the refile node in BLRSITE
  1.  S BHLDA=0 F  S BHLDA=$O(BHLSEQ(BHLDA)) Q:'BHLDA  D
  1.  . S BHLIEN=$G(BHLSEQ(BHLDA))
  1.  . D ^BLREVTQ("M","REFILE","REFILE",,BHLIEN)
  1.  Q
  1.  ;