BHLRLABS ; cmi/anchorage/maw - BHL ORU/R01 Ref Lab inbound Lab Message ; 08 Nov 2005 11:41 AM
;;3.01;BHL IHS Interfaces with GIS;**13,14,16**;AUG 01, 2004
;
;SCC INBOUND
;
;this routine will file the inbound softcore lab message.
;
MAIN ;EP -- this is the main routine driver
S BHLNOST=1 D ^BHLSETI
S BHLRL=+$G(^BLRSITE(DUZ(2),"RL"))
Q:'$G(BHLRL)
;I '$P($G(^BLRRL(BHLRL,0)),U,10) D ORU^BLRHL7(BHLUIF),EOJ Q 2/25/2008 cmi/maw orig
I '$P($G(^BLRSITE(DUZ(2),"RL")),U,18) D ORU^BLRHL7(BHLUIF),EOJ Q ;NEW cmi/maw 2/25/2008
D ^BHLFO
D CHKPAT
I $D(BHLERR("FATAL")) D Q
. D SNDBUL(BHLUIF,PAT,BHLNM,BHLDOB,BHLSEX)
D PRS
D RFL
D EOJ
D JOB^BLRPARAM ;jump start the link
Q
;
CHKPAT ;-- lookup the patient by chart
N BHLR
S BHLR="PID"
S BHLDA=0,BHLDA=$O(@BHLTMP@(BHLDA)) ;should be one PID
;S PAT=+$G(@BHLTMP@(BHLDA,3)) ;cmi/maw 4/11/03 orig
S PAT=$G(@BHLTMP@(BHLDA,3))
S PAT=+$TR(PAT,"-")
S BHLNM=$G(@BHLTMP@(BHLDA,5))
S BHLDOB=$$HDATE^INHUT($E($G(@BHLTMP@(BHLDA,7)),1,8))
S BHLSEX=$G(@BHLTMP@(BHLDA,8))
S BHLPAT=$$CHKPAT^BHLU(PAT,$G(DUZ(2)))
I '$G(BHLPAT) S BHLERCD="NOPAT" X BHLERR
Q:$D(BHLERR("FATAL"))
S BHLPAT=$$CHKDOB^BHLU(BHLPAT)
I '$G(BHLPAT) S BHLERCD="NOPAT" X BHLERR
Q:$D(BHLERR("FATAL"))
S BHLLOE=$G(DUZ(2))
;cmi/maw added 1/7/2003
S BHLLOC=$P($G(^BLRRL(BHLRL,0)),U,15)
I $G(BHLLOC) S BHLLOCE=$P($G(^SC(BHLLOC,0)),U)
Q
;
PRS ;-- parse the HL7 message array
D PV1
D OBR
Q
;
PV1 ;-- pat the PV1 segment
N BHLR
S BHLR="PV1"
N BHLPDA
S BHLPDA=0 F S BHLPDA=$O(@BHLTMP@(BHLPDA)) Q:BHLPDA="" D
. K BHLPCLN,BHLPFTS,BHLPCLNE
. N BHLDTA
. S BHLDTA=$P($G(@BHLTMP@(BHLPDA,3)),CS)
. I $G(BHLDTA) D
.. N BHLDTAI
.. S BHLDTAI=$O(^BMS4(90230.2,"B",BHLDTA,0))
.. Q:'$G(BHLDTAI)
.. S BHLPCLN=$P($G(^BMS4(90230.2,BHLDTAI,0)),U,2)
.. S BHLPCLNE=$$GET1^DIQ(90230.2,BHLDTAI,1)
.. S BHLPFTS=$$GET1^DIQ(90230.2,BHLDTAI,2)
Q
;
OBR ;-- parse the OBR segment
N BHLR
S BHLR="OBR"
S BHLODA=0 F S BHLODA=$O(@BHLTMP@(BHLODA)) Q:BHLODA="" D
. K BHLPAR,BHLTST,BHLPSEQ,BHLCLTE,BHLRSLT,BHLREFR,BHLREFL,BHLREFH
. K BHLABN,BHLUNIT,BHLRESDT,BHLCLT
. S BHLACC=$G(@BHLTMP@(BHLODA,2))
. I $G(BHLACC)="" S BHLACC=$G(@BHLTMP@(BHLODA,3))
. S BHLTST=$P($G(@BHLTMP@(BHLODA,4)),CS)
. S BHLCLTE=$P($G(@BHLTMP@(BHLODA,4)),CS,2)
. S BHLOBSDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,7)),"T")
. S BHLODT=$P(BHLOBSDT,".") ;order date
. S BHLSPDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,14)),"T")
. S BHLORDP=$P($G(@BHLTMP@(BHLODA,16)),"^")
. S BHLRESDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,22)),"T")
. S BHLPAR=BHLODA
. D MAP
. I '$G(BHLCLT) D Q
.. S BHLERR("FATAL")=1
.. D BUL
. I $D(BHL("OBX",BHLODA,2)) D CPT,FILE K BHLCPTS S BHLPSEQ=BHLSEQ
. I $G(BHLPSEQ),$D(INV("NTE3",BHLODA,1)) K BHLCMT D NTEOBR(BHLODA,0)
. I '$G(BHLPSEQ),$D(INV("NTE3",BHLODA,1)) D NTEOBR(BHLODA,1)
. ;I $D(BHLERR("WARNING")) D BUL
. K BHLERR("WARNING")
. D OBX
Q
;
OBX ;-- parse the OBX segment
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. K BHLSPAR,BHLTST,BHLCLTE,BHLRSLT,BHLUNIT,BHLREFR,BHLREFL,BHLREFH
. K BHLABN,BHLUNIT,BHLRESDT,BHLCLT
. S BHLTST=$P($G(@BHLSTMP@(BHLXDA,3)),CS)
. S BHLCLTE=$P($G(@BHLSTMP@(BHLXDA,3)),CS,2)
. S BHLRSLT=$G(@BHLSTMP@(BHLXDA,5))
. ;Q:$G(BHLRSLT)="DNR"
. S BHLUNIT=$G(@BHLSTMP@(BHLXDA,6))
. S BHLREFR=$G(@BHLSTMP@(BHLXDA,7))
. S BHLREFL=BHLREFR
. I $E(BHLREFR,1,1)?.N D
.. S BHLREFL=$P($G(BHLREFR),"-")
.. S BHLREFH=$P($G(BHLREFR),"-",2)
. S BHLABN=$G(@BHLSTMP@(BHLXDA,8))
. S BHLRESDT=$$HDATE^INHUT($G(@BHLSTMP@(BHLXDA,14)),"T")
. S BHLSPAR=BHLXDA
. I BHLTST="" D BUL Q ;cmi/anch/maw 4/10/2006
. D TESTMAP
. I '$G(BHLPSEQ) D CPT
. I '$G(BHLCLT) D BUL Q
. D FILE
. K BHLCPTS,BHLRSLT,BHLUNIT,BHLREFR,BHLREFL,BHLREFH
. D NTE
. K BHLCMT
. I $D(BHLERR("WARNING")) D BUL
. K BHLERR("WARNING")
Q
;
NTEOBR(ODA,BHLSNGL) ;-- parse the NTE in the OBR segment
K BHLCCNT
S BHLCCNT=1
N BHLR
S BHLR="NTE"
S BHLNDA=0 F S BHLNDA=$O(INV("NTE3",BHLODA,BHLNDA)) Q:BHLNDA="" D
. S:'$D(BHLCMT(BHLCCNT)) BHLCMT(BHLCCNT)=0
. S (BHLCMT(BHLCCNT),X)=$TR($G(INV("NTE3",BHLODA,BHLNDA)),"""","'")
. Q:$G(X)=""
. S BHLCCNT=BHLCCNT+1
. Q:$G(BHLSNGL)
. K DIC,DD,DO
. S DIC="^BLRTXLOG("_BHLPSEQ_",30,"
. S DA(1)=BHLPSEQ,DIC(0)="L",DIC("P")=$P(^DD(9009022,3001,0),"^",2)
. D FILE^DICN
Q
;
NTE ;-- parse the NTE segment
I '$G(BHLCCNT) S BHLCCNT=1
N BHLR
S BHLR="NTE"
S BHLNDA=0 F S BHLNDA=$O(@BHLSSTMP@(BHLNDA)) Q:BHLNDA="" D
. S:'$D(BHLCMT(BHLCCNT)) BHLCMT(BHLCCNT)=0
. S (BHLCMT(BHLCCNT),X)=$G(@BHLSSTMP@(BHLNDA,3))
. S BHLCCNT=BHLCCNT+1
D FILENTE
Q
;
FILENTE ;-- file the NTE segments
N BHLCDA
S BHLCDA=0 F S BHLCDA=$O(BHLCMT(BHLCDA)) Q:'BHLCDA D
. S X=$G(BHLCMT(BHLCDA))
. K DIC,DD,DO
. S DIC="^BLRTXLOG("_BHLSEQ_",30,"
. S DA(1)=BHLSEQ,DIC(0)="L",DIC("P")=$P(^DD(9009022,3001,0),"^",2)
. D FILE^DICN
K BHLCMT
Q
;
MAP ;-- map the necessary incoming items to rpms
I '$G(BHLORDP) S BHLORDP=$P($G(BHL("ORC",1,12)),U)
I $G(BHLORDP) S BHLORDP=$$LZERO^BHLPID(BHLORDP,5)
I $G(BHLORDP) S BHLORDPI=$O(^VA(200,"MS4P",BHLORDP,0))
;I $G(BHLORDP)]"" D
;. S BHLORDPI=$O(^VA(200,"AUPIN",BHLORDP,0))
;S BHLORDPE=$S(BHLORDP'="":$P($G(^DIC(6,BHLORDP,0)),U),1:"")
I '$G(BHLORDPI) S BHLORDPI=$O(^VA(200,"B","TECHNICIAN,LAB",0))
I $G(BHLORDPI) S BHLORDPE=$P($G(^VA(200,BHLORDPI,0)),U)
S BHLPNM=$$VAL^XBDIQ1(2,BHLPAT,.01)
S BHLLOE=$G(DUZ(2))
TESTMAP ;
S BHLCLTI=$O(^BLRRL("BTST",BHLTST,BHLRL,0))
;I BHLCLTI="" S BHLERCD="NOLCODE" X BHLERR D BUL Q ;maw orig 10/10/03
I BHLCLTI="" Q ;maw mod 10/10/03
S BHLCLT=$P($G(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2)
;I BHLCLT="" S BHLERCD="NOLAB" X BHLERR D BUL
Q
;
CPT ;-- let's build the cpt string
Q:'$P($G(^BLRRL(BHLRL,0)),U,17) ;don't pass if set to yes
Q:$G(BHLPSEQ)
Q:'$G(BHLCLT)
S BHLCTST=$O(^BLRCPT("C",BHLCLT,0))
Q:BHLCTST=""
S BHLCCNT=0
S BHLCPTS="|||||"
S BHLCDA=0 F S BHLCDA=$O(^BLRCPT(BHLCTST,11,BHLCDA)) Q:'BHLCDA D
. S BHLCPT=$P($G(^BLRCPT(BHLCTST,11,BHLDA,0)),U)
. S BHLCCNT=BHLCCNT+1
. S $P(BHLCPTS,"|",BHLCCNT)=$G(BHLCPT)
Q
;
FILE ;-- file the data in BLRTXLOG
;FORMAT IS BLRVARS="FIELD NAME_VARIABLE~FIELD NAME_VARIABLE""
Q:$G(BHLRSLT)="DNR" ;don't file Do NOT REPORT results
;Q:'$G(BHLCLT)
I '$G(BHLCLT) K BHLSEQ
I $G(BHLCLTI)="" S BHLERCD="NOLCODE" X BHLERR D BUL
I $G(BHLCLT)="" S BHLERCD="NOLAB" X BHLERR D BUL
;cmi/anch/maw added 1/17/2006
I $G(BHLUIF) Q:$O(^BLRTXLOG("AHL7",BHLUIF_BHLCLT,0)) ;don't refile tests that are already there
;cmi/anch/maw end 1/17/2006
K BLR,BLRF,BLRFDA ;maw test
S BHLQSIT=$P($G(^AUTTSITE(1,0)),U)
Q:BHLQSIT=""
S BLRPCC=$P($G(^BLRSITE(BHLQSIT,0)),U,3)
S (BLRODTM,BLRSEQ,BLRTEST1)="",BLRLINK=1,BLRERR=0,BHLPHASE="R",BLRCMF="C"
S BLRXPCC=1 ;after patch 10
S BHLSEQ=$$GETIEN^BLRFLTL(BLRODTM,BLRSEQ,BLRTEST1)
I BHLCLTI="" S BHLERCD="NOLCODE" X BHLERR D BUL
I BHLCLT="" S BHLERCD="NOLAB" X BHLERR D BUL
S BLRVARS="SEQUENCE NUMBER_BHLSEQ~STATUS FLAG_BHLPHASE~DUZ(2)_BHLLOE~"
S BLRVARS=BLRVARS_"PATIENT NAME_$G(BHLPNM)~PATIENT POINTER VALUE_$G(BHLPAT)~ACCESSION NUMBER_BHLACC~"
S BLRVARS=BLRVARS_"ORDERING PROVIDER NAME_$G(BHLORDPE)~ORDERING PROVIDER POINTER_$G(BHLORDPI)~"
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)~"
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)~"
S BHLLM="CH",BLRVARS=BLRVARS_"LAB MODULE_BHLLM~"
S BHLIO="E",BLRVARS=BLRVARS_"I/O CATEGORY_BHLIO~"
S BHLSTAT="R",BLRVARS=BLRVARS_"STATUS FLAG_BHLSTAT~"
S BHLBILL=1,BLRVARS=BLRVARS_"BILLABLE ITEM_BHLBILL~"
S BHLSRC="R",BLRVARS=BLRVARS_"SOURCE OF DATA INPUT_BHLSRC~"
S BHLSPC="",BLRVARS=BLRVARS_"SITE/SPECIMEN POINTER_BHLSPC~"
S BHLSPCE="",BLRVARS=BLRVARS_"SITE/SPECIMEN NAME_BHLSPCE~"
S BHLLFLE=2,BLRVARS=BLRVARS_"LRFILE_BHLLFLE~"
S BLRVARS=BLRVARS_"RESULT N/A FLAG_$G(BHLABN)~"
S BLRVARS=BLRVARS_"BILLING CPT STRING_$G(BHLCPTS)~"
S BLRVARS=BLRVARS_"CLINIC STOP CODE POINTER_$G(BHLPCLN)~CLINIC STOP NAME_$G(BHLPCLNE)~"
S BLRVARS=BLRVARS_"HL7 MESSAGE IEN_$G(BHLUIF)"
I '$D(BLRF(0)) D INIT^BLRPARAM ;after patch 10
;I '$D(BLRF(0)) D ^BLRPARAM
D SETVALS^BLRFLTL ;after patch 10
;D ^BLRFLTL("C",BLRVARS) ;before patch 10
D ^BLRNFLTL ;after patch 10
Q
;
BUL ;-- file a bulletin if no test match
;cmi/anch/maw added collection date and accession number
S XMB="BHL NO TEST MATCH"
S XMB(1)=$G(BHLTST),XMB(2)=$G(BHLCLTE),XMB(3)=$G(BHLSEQ),XMB(4)=$G(UIF)
S XMB(5)=$$FMTE^XLFDT(BHLOBSDT),XMB(6)=$G(BHLACC)
D ^XMB
Q
;
SNDBUL(VAR,VAR1,VAR2,VAR3,VAR4) ;-- fire a generic bulletin
S XMB="BHL REFLAB NO PAT",XMB(1)=VAR,XMB(2)=VAR1,XMB(3)=VAR2
S XMB(4)=$$FMTE^XLFDT(VAR3),XMB(5)=VAR4
;cmi/anch/maw 10/1/2004 let's try and grab the collection date and accession number here
N VAR5,VAR6,BHLR
S BHLR="OBR"
S VAR5=$$HDATE^INHUT($G(@BHLTMP@(1,7)),"T") ;collection date
I $G(VAR5) S VAR5=$$FMTE^XLFDT(VAR5) ;external date format
S VAR6=$G(@BHLTMP@(1,3)) ;accession number
S XMB(6)=$G(VAR5),XMB(7)=$G(VAR6)
D ^XMB
Q
;
EOJ ;-- kill variables and quit
D EN^XBVK("BLR")
D EOJ^BHLSETI
Q
;
RFL ;-- set the refile node in BLRSITE
S BHLDA=0 F S BHLDA=$O(BHLSEQ(BHLDA)) Q:'BHLDA D
. S BHLIEN=$G(BHLSEQ(BHLDA))
. D ^BLREVTQ("M","REFILE","REFILE",,BHLIEN)
Q
;
BHLRLABS ; cmi/anchorage/maw - BHL ORU/R01 Ref Lab inbound Lab Message ; 08 Nov 2005 11:41 AM
+1 ;;3.01;BHL IHS Interfaces with GIS;**13,14,16**;AUG 01, 2004
+2 ;
+3 ;SCC INBOUND
+4 ;
+5 ;this routine will file the inbound softcore lab message.
+6 ;
MAIN ;EP -- this is the main routine driver
+1 SET BHLNOST=1
DO ^BHLSETI
+2 SET BHLRL=+$GET(^BLRSITE(DUZ(2),"RL"))
+3 IF '$GET(BHLRL)
QUIT
+4 ;I '$P($G(^BLRRL(BHLRL,0)),U,10) D ORU^BLRHL7(BHLUIF),EOJ Q 2/25/2008 cmi/maw orig
+5 ;NEW cmi/maw 2/25/2008
IF '$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,18)
DO ORU^BLRHL7(BHLUIF)
DO EOJ
QUIT
+6 DO ^BHLFO
+7 DO CHKPAT
+8 IF $DATA(BHLERR("FATAL"))
Begin DoDot:1
+9 DO SNDBUL(BHLUIF,PAT,BHLNM,BHLDOB,BHLSEX)
End DoDot:1
QUIT
+10 DO PRS
+11 DO RFL
+12 DO EOJ
+13 ;jump start the link
DO JOB^BLRPARAM
+14 QUIT
+15 ;
CHKPAT ;-- lookup the patient by chart
+1 NEW BHLR
+2 SET BHLR="PID"
+3 ;should be one PID
SET BHLDA=0
SET BHLDA=$ORDER(@BHLTMP@(BHLDA))
+4 ;S PAT=+$G(@BHLTMP@(BHLDA,3)) ;cmi/maw 4/11/03 orig
+5 SET PAT=$GET(@BHLTMP@(BHLDA,3))
+6 SET PAT=+$TRANSLATE(PAT,"-")
+7 SET BHLNM=$GET(@BHLTMP@(BHLDA,5))
+8 SET BHLDOB=$$HDATE^INHUT($EXTRACT($GET(@BHLTMP@(BHLDA,7)),1,8))
+9 SET BHLSEX=$GET(@BHLTMP@(BHLDA,8))
+10 SET BHLPAT=$$CHKPAT^BHLU(PAT,$GET(DUZ(2)))
+11 IF '$GET(BHLPAT)
SET BHLERCD="NOPAT"
XECUTE BHLERR
+12 IF $DATA(BHLERR("FATAL"))
QUIT
+13 SET BHLPAT=$$CHKDOB^BHLU(BHLPAT)
+14 IF '$GET(BHLPAT)
SET BHLERCD="NOPAT"
XECUTE BHLERR
+15 IF $DATA(BHLERR("FATAL"))
QUIT
+16 SET BHLLOE=$GET(DUZ(2))
+17 ;cmi/maw added 1/7/2003
+18 SET BHLLOC=$PIECE($GET(^BLRRL(BHLRL,0)),U,15)
+19 IF $GET(BHLLOC)
SET BHLLOCE=$PIECE($GET(^SC(BHLLOC,0)),U)
+20 QUIT
+21 ;
PRS ;-- parse the HL7 message array
+1 DO PV1
+2 DO OBR
+3 QUIT
+4 ;
PV1 ;-- pat the PV1 segment
+1 NEW BHLR
+2 SET BHLR="PV1"
+3 NEW BHLPDA
+4 SET BHLPDA=0
FOR
SET BHLPDA=$ORDER(@BHLTMP@(BHLPDA))
IF BHLPDA=""
QUIT
Begin DoDot:1
+5 KILL BHLPCLN,BHLPFTS,BHLPCLNE
+6 NEW BHLDTA
+7 SET BHLDTA=$PIECE($GET(@BHLTMP@(BHLPDA,3)),CS)
+8 IF $GET(BHLDTA)
Begin DoDot:2
+9 NEW BHLDTAI
+10 SET BHLDTAI=$ORDER(^BMS4(90230.2,"B",BHLDTA,0))
+11 IF '$GET(BHLDTAI)
QUIT
+12 SET BHLPCLN=$PIECE($GET(^BMS4(90230.2,BHLDTAI,0)),U,2)
+13 SET BHLPCLNE=$$GET1^DIQ(90230.2,BHLDTAI,1)
+14 SET BHLPFTS=$$GET1^DIQ(90230.2,BHLDTAI,2)
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
OBR ;-- parse the OBR segment
+1 NEW BHLR
+2 SET BHLR="OBR"
+3 SET BHLODA=0
FOR
SET BHLODA=$ORDER(@BHLTMP@(BHLODA))
IF BHLODA=""
QUIT
Begin DoDot:1
+4 KILL BHLPAR,BHLTST,BHLPSEQ,BHLCLTE,BHLRSLT,BHLREFR,BHLREFL,BHLREFH
+5 KILL BHLABN,BHLUNIT,BHLRESDT,BHLCLT
+6 SET BHLACC=$GET(@BHLTMP@(BHLODA,2))
+7 IF $GET(BHLACC)=""
SET BHLACC=$GET(@BHLTMP@(BHLODA,3))
+8 SET BHLTST=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS)
+9 SET BHLCLTE=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,2)
+10 SET BHLOBSDT=$$HDATE^INHUT($GET(@BHLTMP@(BHLODA,7)),"T")
+11 ;order date
SET BHLODT=$PIECE(BHLOBSDT,".")
+12 SET BHLSPDT=$$HDATE^INHUT($GET(@BHLTMP@(BHLODA,14)),"T")
+13 SET BHLORDP=$PIECE($GET(@BHLTMP@(BHLODA,16)),"^")
+14 SET BHLRESDT=$$HDATE^INHUT($GET(@BHLTMP@(BHLODA,22)),"T")
+15 SET BHLPAR=BHLODA
+16 DO MAP
+17 IF '$GET(BHLCLT)
Begin DoDot:2
+18 SET BHLERR("FATAL")=1
+19 DO BUL
End DoDot:2
QUIT
+20 IF $DATA(BHL("OBX",BHLODA,2))
DO CPT
DO FILE
KILL BHLCPTS
SET BHLPSEQ=BHLSEQ
+21 IF $GET(BHLPSEQ)
IF $DATA(INV("NTE3",BHLODA,1))
KILL BHLCMT
DO NTEOBR(BHLODA,0)
+22 IF '$GET(BHLPSEQ)
IF $DATA(INV("NTE3",BHLODA,1))
DO NTEOBR(BHLODA,1)
+23 ;I $D(BHLERR("WARNING")) D BUL
+24 KILL BHLERR("WARNING")
+25 DO OBX
End DoDot:1
+26 QUIT
+27 ;
OBX ;-- parse the OBX segment
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 KILL BHLSPAR,BHLTST,BHLCLTE,BHLRSLT,BHLUNIT,BHLREFR,BHLREFL,BHLREFH
+5 KILL BHLABN,BHLUNIT,BHLRESDT,BHLCLT
+6 SET BHLTST=$PIECE($GET(@BHLSTMP@(BHLXDA,3)),CS)
+7 SET BHLCLTE=$PIECE($GET(@BHLSTMP@(BHLXDA,3)),CS,2)
+8 SET BHLRSLT=$GET(@BHLSTMP@(BHLXDA,5))
+9 ;Q:$G(BHLRSLT)="DNR"
+10 SET BHLUNIT=$GET(@BHLSTMP@(BHLXDA,6))
+11 SET BHLREFR=$GET(@BHLSTMP@(BHLXDA,7))
+12 SET BHLREFL=BHLREFR
+13 IF $EXTRACT(BHLREFR,1,1)?.N
Begin DoDot:2
+14 SET BHLREFL=$PIECE($GET(BHLREFR),"-")
+15 SET BHLREFH=$PIECE($GET(BHLREFR),"-",2)
End DoDot:2
+16 SET BHLABN=$GET(@BHLSTMP@(BHLXDA,8))
+17 SET BHLRESDT=$$HDATE^INHUT($GET(@BHLSTMP@(BHLXDA,14)),"T")
+18 SET BHLSPAR=BHLXDA
+19 ;cmi/anch/maw 4/10/2006
IF BHLTST=""
DO BUL
QUIT
+20 DO TESTMAP
+21 IF '$GET(BHLPSEQ)
DO CPT
+22 IF '$GET(BHLCLT)
DO BUL
QUIT
+23 DO FILE
+24 KILL BHLCPTS,BHLRSLT,BHLUNIT,BHLREFR,BHLREFL,BHLREFH
+25 DO NTE
+26 KILL BHLCMT
+27 IF $DATA(BHLERR("WARNING"))
DO BUL
+28 KILL BHLERR("WARNING")
End DoDot:1
+29 QUIT
+30 ;
NTEOBR(ODA,BHLSNGL) ;-- parse the NTE in the OBR segment
+1 KILL BHLCCNT
+2 SET BHLCCNT=1
+3 NEW BHLR
+4 SET BHLR="NTE"
+5 SET BHLNDA=0
FOR
SET BHLNDA=$ORDER(INV("NTE3",BHLODA,BHLNDA))
IF BHLNDA=""
QUIT
Begin DoDot:1
+6 IF '$DATA(BHLCMT(BHLCCNT))
SET BHLCMT(BHLCCNT)=0
+7 SET (BHLCMT(BHLCCNT),X)=$TRANSLATE($GET(INV("NTE3",BHLODA,BHLNDA)),"""","'")
+8 IF $GET(X)=""
QUIT
+9 SET BHLCCNT=BHLCCNT+1
+10 IF $GET(BHLSNGL)
QUIT
+11 KILL DIC,DD,DO
+12 SET DIC="^BLRTXLOG("_BHLPSEQ_",30,"
+13 SET DA(1)=BHLPSEQ
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9009022,3001,0),"^",2)
+14 DO FILE^DICN
End DoDot:1
+15 QUIT
+16 ;
NTE ;-- parse the NTE segment
+1 IF '$GET(BHLCCNT)
SET BHLCCNT=1
+2 NEW BHLR
+3 SET BHLR="NTE"
+4 SET BHLNDA=0
FOR
SET BHLNDA=$ORDER(@BHLSSTMP@(BHLNDA))
IF BHLNDA=""
QUIT
Begin DoDot:1
+5 IF '$DATA(BHLCMT(BHLCCNT))
SET BHLCMT(BHLCCNT)=0
+6 SET (BHLCMT(BHLCCNT),X)=$GET(@BHLSSTMP@(BHLNDA,3))
+7 SET BHLCCNT=BHLCCNT+1
End DoDot:1
+8 DO FILENTE
+9 QUIT
+10 ;
FILENTE ;-- file the NTE segments
+1 NEW BHLCDA
+2 SET BHLCDA=0
FOR
SET BHLCDA=$ORDER(BHLCMT(BHLCDA))
IF 'BHLCDA
QUIT
Begin DoDot:1
+3 SET X=$GET(BHLCMT(BHLCDA))
+4 KILL DIC,DD,DO
+5 SET DIC="^BLRTXLOG("_BHLSEQ_",30,"
+6 SET DA(1)=BHLSEQ
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9009022,3001,0),"^",2)
+7 DO FILE^DICN
End DoDot:1
+8 KILL BHLCMT
+9 QUIT
+10 ;
MAP ;-- map the necessary incoming items to rpms
+1 IF '$GET(BHLORDP)
SET BHLORDP=$PIECE($GET(BHL("ORC",1,12)),U)
+2 IF $GET(BHLORDP)
SET BHLORDP=$$LZERO^BHLPID(BHLORDP,5)
+3 IF $GET(BHLORDP)
SET BHLORDPI=$ORDER(^VA(200,"MS4P",BHLORDP,0))
+4 ;I $G(BHLORDP)]"" D
+5 ;. S BHLORDPI=$O(^VA(200,"AUPIN",BHLORDP,0))
+6 ;S BHLORDPE=$S(BHLORDP'="":$P($G(^DIC(6,BHLORDP,0)),U),1:"")
+7 IF '$GET(BHLORDPI)
SET BHLORDPI=$ORDER(^VA(200,"B","TECHNICIAN,LAB",0))
+8 IF $GET(BHLORDPI)
SET BHLORDPE=$PIECE($GET(^VA(200,BHLORDPI,0)),U)
+9 SET BHLPNM=$$VAL^XBDIQ1(2,BHLPAT,.01)
+10 SET BHLLOE=$GET(DUZ(2))
TESTMAP ;
+1 SET BHLCLTI=$ORDER(^BLRRL("BTST",BHLTST,BHLRL,0))
+2 ;I BHLCLTI="" S BHLERCD="NOLCODE" X BHLERR D BUL Q ;maw orig 10/10/03
+3 ;maw mod 10/10/03
IF BHLCLTI=""
QUIT
+4 SET BHLCLT=$PIECE($GET(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2)
+5 ;I BHLCLT="" S BHLERCD="NOLAB" X BHLERR D BUL
+6 QUIT
+7 ;
CPT ;-- let's build the cpt string
+1 ;don't pass if set to yes
IF '$PIECE($GET(^BLRRL(BHLRL,0)),U,17)
QUIT
+2 IF $GET(BHLPSEQ)
QUIT
+3 IF '$GET(BHLCLT)
QUIT
+4 SET BHLCTST=$ORDER(^BLRCPT("C",BHLCLT,0))
+5 IF BHLCTST=""
QUIT
+6 SET BHLCCNT=0
+7 SET BHLCPTS="|||||"
+8 SET BHLCDA=0
FOR
SET BHLCDA=$ORDER(^BLRCPT(BHLCTST,11,BHLCDA))
IF 'BHLCDA
QUIT
Begin DoDot:1
+9 SET BHLCPT=$PIECE($GET(^BLRCPT(BHLCTST,11,BHLDA,0)),U)
+10 SET BHLCCNT=BHLCCNT+1
+11 SET $PIECE(BHLCPTS,"|",BHLCCNT)=$GET(BHLCPT)
End DoDot:1
+12 QUIT
+13 ;
FILE ;-- file the data in BLRTXLOG
+1 ;FORMAT IS BLRVARS="FIELD NAME_VARIABLE~FIELD NAME_VARIABLE""
+2 ;don't file Do NOT REPORT results
IF $GET(BHLRSLT)="DNR"
QUIT
+3 ;Q:'$G(BHLCLT)
+4 IF '$GET(BHLCLT)
KILL BHLSEQ
+5 IF $GET(BHLCLTI)=""
SET BHLERCD="NOLCODE"
XECUTE BHLERR
DO BUL
+6 IF $GET(BHLCLT)=""
SET BHLERCD="NOLAB"
XECUTE BHLERR
DO BUL
+7 ;cmi/anch/maw added 1/17/2006
+8 ;don't refile tests that are already there
IF $GET(BHLUIF)
IF $ORDER(^BLRTXLOG("AHL7",BHLUIF_BHLCLT,0))
QUIT
+9 ;cmi/anch/maw end 1/17/2006
+10 ;maw test
KILL BLR,BLRF,BLRFDA
+11 SET BHLQSIT=$PIECE($GET(^AUTTSITE(1,0)),U)
+12 IF BHLQSIT=""
QUIT
+13 SET BLRPCC=$PIECE($GET(^BLRSITE(BHLQSIT,0)),U,3)
+14 SET (BLRODTM,BLRSEQ,BLRTEST1)=""
SET BLRLINK=1
SET BLRERR=0
SET BHLPHASE="R"
SET BLRCMF="C"
+15 ;after patch 10
SET BLRXPCC=1
+16 SET BHLSEQ=$$GETIEN^BLRFLTL(BLRODTM,BLRSEQ,BLRTEST1)
+17 IF BHLCLTI=""
SET BHLERCD="NOLCODE"
XECUTE BHLERR
DO BUL
+18 IF BHLCLT=""
SET BHLERCD="NOLAB"
XECUTE BHLERR
DO BUL
+19 SET BLRVARS="SEQUENCE NUMBER_BHLSEQ~STATUS FLAG_BHLPHASE~DUZ(2)_BHLLOE~"
+20 SET BLRVARS=BLRVARS_"PATIENT NAME_$G(BHLPNM)~PATIENT POINTER VALUE_$G(BHLPAT)~ACCESSION NUMBER_BHLACC~"
+21 SET BLRVARS=BLRVARS_"ORDERING PROVIDER NAME_$G(BHLORDPE)~ORDERING PROVIDER POINTER_$G(BHLORDPI)~"
+22 SET 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)~"
+23 SET 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)~"
+24 SET BHLLM="CH"
SET BLRVARS=BLRVARS_"LAB MODULE_BHLLM~"
+25 SET BHLIO="E"
SET BLRVARS=BLRVARS_"I/O CATEGORY_BHLIO~"
+26 SET BHLSTAT="R"
SET BLRVARS=BLRVARS_"STATUS FLAG_BHLSTAT~"
+27 SET BHLBILL=1
SET BLRVARS=BLRVARS_"BILLABLE ITEM_BHLBILL~"
+28 SET BHLSRC="R"
SET BLRVARS=BLRVARS_"SOURCE OF DATA INPUT_BHLSRC~"
+29 SET BHLSPC=""
SET BLRVARS=BLRVARS_"SITE/SPECIMEN POINTER_BHLSPC~"
+30 SET BHLSPCE=""
SET BLRVARS=BLRVARS_"SITE/SPECIMEN NAME_BHLSPCE~"
+31 SET BHLLFLE=2
SET BLRVARS=BLRVARS_"LRFILE_BHLLFLE~"
+32 SET BLRVARS=BLRVARS_"RESULT N/A FLAG_$G(BHLABN)~"
+33 SET BLRVARS=BLRVARS_"BILLING CPT STRING_$G(BHLCPTS)~"
+34 SET BLRVARS=BLRVARS_"CLINIC STOP CODE POINTER_$G(BHLPCLN)~CLINIC STOP NAME_$G(BHLPCLNE)~"
+35 SET BLRVARS=BLRVARS_"HL7 MESSAGE IEN_$G(BHLUIF)"
+36 ;after patch 10
IF '$DATA(BLRF(0))
DO INIT^BLRPARAM
+37 ;I '$D(BLRF(0)) D ^BLRPARAM
+38 ;after patch 10
DO SETVALS^BLRFLTL
+39 ;D ^BLRFLTL("C",BLRVARS) ;before patch 10
+40 ;after patch 10
DO ^BLRNFLTL
+41 QUIT
+42 ;
BUL ;-- file a bulletin if no test match
+1 ;cmi/anch/maw added collection date and accession number
+2 SET XMB="BHL NO TEST MATCH"
+3 SET XMB(1)=$GET(BHLTST)
SET XMB(2)=$GET(BHLCLTE)
SET XMB(3)=$GET(BHLSEQ)
SET XMB(4)=$GET(UIF)
+4 SET XMB(5)=$$FMTE^XLFDT(BHLOBSDT)
SET XMB(6)=$GET(BHLACC)
+5 DO ^XMB
+6 QUIT
+7 ;
SNDBUL(VAR,VAR1,VAR2,VAR3,VAR4) ;-- fire a generic bulletin
+1 SET XMB="BHL REFLAB NO PAT"
SET XMB(1)=VAR
SET XMB(2)=VAR1
SET XMB(3)=VAR2
+2 SET XMB(4)=$$FMTE^XLFDT(VAR3)
SET XMB(5)=VAR4
+3 ;cmi/anch/maw 10/1/2004 let's try and grab the collection date and accession number here
+4 NEW VAR5,VAR6,BHLR
+5 SET BHLR="OBR"
+6 ;collection date
SET VAR5=$$HDATE^INHUT($GET(@BHLTMP@(1,7)),"T")
+7 ;external date format
IF $GET(VAR5)
SET VAR5=$$FMTE^XLFDT(VAR5)
+8 ;accession number
SET VAR6=$GET(@BHLTMP@(1,3))
+9 SET XMB(6)=$GET(VAR5)
SET XMB(7)=$GET(VAR6)
+10 DO ^XMB
+11 QUIT
+12 ;
EOJ ;-- kill variables and quit
+1 DO EN^XBVK("BLR")
+2 DO EOJ^BHLSETI
+3 QUIT
+4 ;
RFL ;-- set the refile node in BLRSITE
+1 SET BHLDA=0
FOR
SET BHLDA=$ORDER(BHLSEQ(BHLDA))
IF 'BHLDA
QUIT
Begin DoDot:1
+2 SET BHLIEN=$GET(BHLSEQ(BHLDA))
+3 DO ^BLREVTQ("M","REFILE","REFILE",,BHLIEN)
End DoDot:1
+4 QUIT
+5 ;
