BHLRLABT ; cmi/anchorage/maw - BHL ORU/R01 Ref Lab inbound Lab Message ; [ 02/28/2005 3:40 PM ]
;;3.01;BHL IHS Interfaces with GIS;**13,14,15,16**;AUG 01, 2004
;
;TRICORE INBOUND
;
;this routine will file the inbound 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 MSH
D CHKPAT
I $D(BHLERR("FATAL")) D Q
. D SNDBUL(BHLUIF,PAT,BHLNM,BHLDOB,BHLSEX)
K BHLSAF
D PRS
D RFL
D EOJ
D JOB^BLRPARAM ;jump start the link
Q
;
MSH ;-- get data out of MSH
S BHLDUZ2=DUZ(2)
S BHLACT=BHLRAF
I $G(BHLACT) S BHLDUZ2=$O(^BLRSITE("ACCT",BHLACT,0)) ;cmi/flag/maw 11/17/2003 now looking in BLR Master Control File
I '$G(BHLDUZ2) S BHLDUZ2=DUZ(2)
;I BHLACT=4107080 S BHLDUZ2=4618
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))
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(BHLDUZ2))
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(BHLDUZ2)
S BHLLOC=$P($G(^BLRSITE(BHLDUZ2,"RL")),U,9)
I $G(BHLLOC) S BHLLOCE=$P($G(^SC(BHLLOC,0)),U)
Q
;
PRS ;-- parse the HL7 message array
D OBR
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
. S BHLACC=$G(@BHLTMP@(BHLODA,2))
. I $G(BHLACC)["" S BHLACC=$G(@BHLTMP@(BHLODA,3))
. I $G(BHLACC)[U S BHLACC="" ;maw test 2/10/2005
. 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 BHLSPDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,14)),"T")
. S BHLORDP=$P($G(@BHLTMP@(BHLODA,16)),CS)
. S BHLRESDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,22)),"T")
. S BHLPAR=BHLODA
. D MAP("ORDER")
. 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(BHL("NTE",BHLODA,1)) D NTEOBR
. I $D(BHLERR("WARNING")) D BUL
. K BHLERR("WARNING")
. I '$D(BHL("OBX",BHLODA,1)) D CPT,FILE K BHLCPTS
. I '$D(BHL("OBX",BHLODA,1)),$D(BHL("NTE",BHLODA,1)) S BHLPSEQ=BHLSEQ D NTEOBR
. D OBX
Q
;
NTEOBR ;-- nte obr segment
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
. S BHLTST=$P($G(@BHLSTMP@(BHLXDA,3)),CS)
. S BHLCLTE=$P($G(@BHLSTMP@(BHLXDA,3)),CS,2)
. S BHLRSLT=$G(@BHLSTMP@(BHLXDA,5))
. 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
. 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
;
NTE ;-- parse the NTE segment
N BHLR
S BHLR="NTE"
S BHLNDA=0 F S BHLNDA=$O(@BHLSSTMP@(BHLNDA)) Q:BHLNDA="" D
. S:'$D(BHLCMT(BHLNDA)) BHLCMT(BHLNDA)=0
. S (BHLCMT(BHLNDA),X)=$G(@BHLSSTMP@(BHLNDA,3))
. 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
Q
;
MAP(BHLTYPC) ;-- map the necessary incoming items to rpms
I $G(BHLORDP)]"" D
. S BHLORDPI=$O(^VA(200,"AUPIN",BHLORDP,0))
I '$G(BHLORDPI) D
. S BHLORDPI=$O(^VA(200,"ANPI",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 ;
N BHLZDA
K BHLCLTI,BHLCLT
S BHLZDA=0 F S BHLZDA=$O(^BLRRL("BTST",BHLTST,BHLRL,BHLZDA)) Q:'BHLZDA D
. 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
. 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
;S BHLCLTI=$O(^BLRRL("BTST",BHLTST,BHLRL,0))
;I BHLCLTI="" S BHLERCD="NOLCODE" X BHLERR Q
;S BHLCLT=$P($G(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2)
;I BHLCLT="" S BHLERCD="NOLAB" X BHLERR
Q
;
CPT ;-- let's build the cpt string
K BHLIO
Q:'$P($G(^BLRRL(BHLRL,0)),U,17)
S BHLIO="A"
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""
K BLR,BLRF,BLRFDA ;maw test
Q:$G(BHLRSLT)="DNR"
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
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)
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=$S($G(BHLIO)]"":BHLIO,1:"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=999,BLRVARS=BLRVARS_"SITE/SPECIMEN POINTER_BHLSPC~"
S BHLSPCE="UNKNOWN",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_"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
S XMB="BHL NO TEST MATCH"
S XMB(1)=$G(BHLTST),XMB(2)=$G(BHLCLTE),XMB(3)=$G(BHLSEQ)
S 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
N VAR5,BAR6,BHLR
S BHLR="OBR"
S VAR5=$$HDATE^INHUT($G(@BHLTMP@(1,7)),"T") ;collection date
I $G(VAR5) S VAR5=$$FMTE^XLFDT(VAR5) ;external 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
;
RORC ;-- remove orc segments from messge
N BHLRDA,BHLCNT,BHLFLG
S BHLCNT=0,BHLFLG=0
S BHLRDA=0 F S BHLRDA=$O(^INTHU(UIF,3,BHLRDA)) Q:'BHLRDA D
. S BHLCNT=BHLCNT+1
. I $E($G(^INTHU(UIF,3,BHLRDA,0)),1,3)="ORC" D Q
.. K ^INTHU(UIF,3,BHLRDA,0)
.. S BHLCNT=BHLCNT-1
.. S BHLFLG=1
. S ^BHLTMP($J,UIF,3,BHLCNT,0)=$G(^INTHU(UIF,3,BHLRDA,0))
. K ^INTHU(UIF,3,BHLRDA,0)
N BHLTDA
S BHLTDA=0 F S BHLTDA=$O(^BHLTMP($J,UIF,3,BHLTDA)) Q:'BHLTDA D
. S ^INTHU(UIF,3,BHLTDA,0)=$G(^BHLTMP($J,UIF,3,BHLTDA,0))
Q
;
BHLRLABT ; cmi/anchorage/maw - BHL ORU/R01 Ref Lab inbound Lab Message ; [ 02/28/2005 3:40 PM ]
+1 ;;3.01;BHL IHS Interfaces with GIS;**13,14,15,16**;AUG 01, 2004
+2 ;
+3 ;TRICORE INBOUND
+4 ;
+5 ;this routine will file the inbound 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 MSH
+8 DO CHKPAT
+9 IF $DATA(BHLERR("FATAL"))
Begin DoDot:1
+10 DO SNDBUL(BHLUIF,PAT,BHLNM,BHLDOB,BHLSEX)
End DoDot:1
QUIT
+11 KILL BHLSAF
+12 DO PRS
+13 DO RFL
+14 DO EOJ
+15 ;jump start the link
DO JOB^BLRPARAM
+16 QUIT
+17 ;
MSH ;-- get data out of MSH
+1 SET BHLDUZ2=DUZ(2)
+2 SET BHLACT=BHLRAF
+3 ;cmi/flag/maw 11/17/2003 now looking in BLR Master Control File
IF $GET(BHLACT)
SET BHLDUZ2=$ORDER(^BLRSITE("ACCT",BHLACT,0))
+4 IF '$GET(BHLDUZ2)
SET BHLDUZ2=DUZ(2)
+5 ;I BHLACT=4107080 S BHLDUZ2=4618
+6 QUIT
+7 ;
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 SET PAT=+$GET(@BHLTMP@(BHLDA,3))
+5 SET BHLNM=$GET(@BHLTMP@(BHLDA,5))
+6 SET BHLDOB=$$HDATE^INHUT($EXTRACT($GET(@BHLTMP@(BHLDA,7)),1,8))
+7 SET BHLSEX=$GET(@BHLTMP@(BHLDA,8))
+8 SET BHLPAT=$$CHKPAT^BHLU(PAT,$GET(BHLDUZ2))
+9 IF '$GET(BHLPAT)
SET BHLERCD="NOPAT"
XECUTE BHLERR
+10 IF $DATA(BHLERR("FATAL"))
QUIT
+11 SET BHLPAT=$$CHKDOB^BHLU(BHLPAT)
+12 IF '$GET(BHLPAT)
SET BHLERCD="NOPAT"
XECUTE BHLERR
+13 IF $DATA(BHLERR("FATAL"))
QUIT
+14 SET BHLLOE=$GET(BHLDUZ2)
+15 SET BHLLOC=$PIECE($GET(^BLRSITE(BHLDUZ2,"RL")),U,9)
+16 IF $GET(BHLLOC)
SET BHLLOCE=$PIECE($GET(^SC(BHLLOC,0)),U)
+17 QUIT
+18 ;
PRS ;-- parse the HL7 message array
+1 DO OBR
+2 QUIT
+3 ;
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
+5 SET BHLACC=$GET(@BHLTMP@(BHLODA,2))
+6 IF $GET(BHLACC)[""
SET BHLACC=$GET(@BHLTMP@(BHLODA,3))
+7 ;maw test 2/10/2005
IF $GET(BHLACC)[U
SET BHLACC=""
+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 SET BHLSPDT=$$HDATE^INHUT($GET(@BHLTMP@(BHLODA,14)),"T")
+12 SET BHLORDP=$PIECE($GET(@BHLTMP@(BHLODA,16)),CS)
+13 SET BHLRESDT=$$HDATE^INHUT($GET(@BHLTMP@(BHLODA,22)),"T")
+14 SET BHLPAR=BHLODA
+15 DO MAP("ORDER")
+16 IF '$GET(BHLCLT)
Begin DoDot:2
+17 SET BHLERR("FATAL")=1
+18 DO BUL
End DoDot:2
QUIT
+19 IF $DATA(BHL("OBX",BHLODA,2))
DO CPT
DO FILE
KILL BHLCPTS
SET BHLPSEQ=BHLSEQ
+20 IF $GET(BHLPSEQ)
IF $DATA(BHL("NTE",BHLODA,1))
DO NTEOBR
+21 IF $DATA(BHLERR("WARNING"))
DO BUL
+22 KILL BHLERR("WARNING")
+23 IF '$DATA(BHL("OBX",BHLODA,1))
DO CPT
DO FILE
KILL BHLCPTS
+24 IF '$DATA(BHL("OBX",BHLODA,1))
IF $DATA(BHL("NTE",BHLODA,1))
SET BHLPSEQ=BHLSEQ
DO NTEOBR
+25 DO OBX
End DoDot:1
+26 QUIT
+27 ;
NTEOBR ;-- nte obr segment
+1 QUIT
+2 ;
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
+5 SET BHLTST=$PIECE($GET(@BHLSTMP@(BHLXDA,3)),CS)
+6 SET BHLCLTE=$PIECE($GET(@BHLSTMP@(BHLXDA,3)),CS,2)
+7 SET BHLRSLT=$GET(@BHLSTMP@(BHLXDA,5))
+8 SET BHLUNIT=$GET(@BHLSTMP@(BHLXDA,6))
+9 SET BHLREFR=$GET(@BHLSTMP@(BHLXDA,7))
+10 SET BHLREFL=BHLREFR
+11 IF $EXTRACT(BHLREFR,1,1)?.N
Begin DoDot:2
+12 SET BHLREFL=$PIECE($GET(BHLREFR),"-")
+13 SET BHLREFH=$PIECE($GET(BHLREFR),"-",2)
End DoDot:2
+14 SET BHLABN=$GET(@BHLSTMP@(BHLXDA,8))
+15 SET BHLRESDT=$$HDATE^INHUT($GET(@BHLSTMP@(BHLXDA,14)),"T")
+16 SET BHLSPAR=BHLXDA
+17 DO TESTMAP
+18 IF '$GET(BHLPSEQ)
DO CPT
+19 IF '$GET(BHLCLT)
DO BUL
QUIT
+20 DO FILE
+21 KILL BHLCPTS,BHLRSLT,BHLUNIT,BHLREFR,BHLREFL,BHLREFH
+22 DO NTE
+23 KILL BHLCMT
+24 IF $DATA(BHLERR("WARNING"))
DO BUL
+25 KILL BHLERR("WARNING")
End DoDot:1
+26 QUIT
+27 ;
NTE ;-- parse the NTE segment
+1 NEW BHLR
+2 SET BHLR="NTE"
+3 SET BHLNDA=0
FOR
SET BHLNDA=$ORDER(@BHLSSTMP@(BHLNDA))
IF BHLNDA=""
QUIT
Begin DoDot:1
+4 IF '$DATA(BHLCMT(BHLNDA))
SET BHLCMT(BHLNDA)=0
+5 SET (BHLCMT(BHLNDA),X)=$GET(@BHLSSTMP@(BHLNDA,3))
+6 KILL DIC,DD,DO
+7 SET DIC="^BLRTXLOG("_BHLSEQ_",30,"
+8 SET DA(1)=BHLSEQ
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9009022,3001,0),"^",2)
+9 DO FILE^DICN
End DoDot:1
+10 QUIT
+11 ;
MAP(BHLTYPC) ;-- map the necessary incoming items to rpms
+1 IF $GET(BHLORDP)]""
Begin DoDot:1
+2 SET BHLORDPI=$ORDER(^VA(200,"AUPIN",BHLORDP,0))
End DoDot:1
+3 IF '$GET(BHLORDPI)
Begin DoDot:1
+4 SET BHLORDPI=$ORDER(^VA(200,"ANPI",BHLORDP,0))
End DoDot:1
+5 ;S BHLORDPE=$S(BHLORDP'="":$P($G(^DIC(6,BHLORDP,0)),U),1:"")
+6 IF '$GET(BHLORDPI)
SET BHLORDPI=$ORDER(^VA(200,"B","TECHNICIAN,LAB",0))
+7 IF $GET(BHLORDPI)
SET BHLORDPE=$PIECE($GET(^VA(200,BHLORDPI,0)),U)
+8 SET BHLPNM=$$VAL^XBDIQ1(2,BHLPAT,.01)
+9 SET BHLLOE=$GET(DUZ(2))
TESTMAP ;
+1 NEW BHLZDA
+2 KILL BHLCLTI,BHLCLT
+3 SET BHLZDA=0
FOR
SET BHLZDA=$ORDER(^BLRRL("BTST",BHLTST,BHLRL,BHLZDA))
IF 'BHLZDA
QUIT
Begin DoDot:1
+4 IF $GET(BHLTYPC)]""
IF $PIECE($GET(^BLRRL(BHLRL,1,BHLZDA,0)),U,3)
SET BHLCLTI=BHLZDA
SET BHLCLT=$PIECE($GET(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2)
QUIT
+5 IF $GET(BHLTYPC)=""
IF $PIECE($GET(^BLRRL(BHLRL,1,BHLZDA,0)),U,4)
SET BHLCLTI=BHLZDA
SET BHLCLT=$PIECE($GET(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2)
QUIT
End DoDot:1
+6 ;S BHLCLTI=$O(^BLRRL("BTST",BHLTST,BHLRL,0))
+7 ;I BHLCLTI="" S BHLERCD="NOLCODE" X BHLERR Q
+8 ;S BHLCLT=$P($G(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2)
+9 ;I BHLCLT="" S BHLERCD="NOLAB" X BHLERR
+10 QUIT
+11 ;
CPT ;-- let's build the cpt string
+1 KILL BHLIO
+2 IF '$PIECE($GET(^BLRRL(BHLRL,0)),U,17)
QUIT
+3 SET BHLIO="A"
+4 IF $GET(BHLPSEQ)
QUIT
+5 IF '$GET(BHLCLT)
QUIT
+6 SET BHLCTST=$ORDER(^BLRCPT("C",BHLCLT,0))
+7 IF BHLCTST=""
QUIT
+8 SET BHLCCNT=0
+9 SET BHLCPTS="|||||"
+10 SET BHLCDA=0
FOR
SET BHLCDA=$ORDER(^BLRCPT(BHLCTST,11,BHLCDA))
IF 'BHLCDA
QUIT
Begin DoDot:1
+11 SET BHLCPT=$PIECE($GET(^BLRCPT(BHLCTST,11,BHLDA,0)),U)
+12 SET BHLCCNT=BHLCCNT+1
+13 SET $PIECE(BHLCPTS,"|",BHLCCNT)=$GET(BHLCPT)
End DoDot:1
+14 QUIT
+15 ;
FILE ;-- file the data in BLRTXLOG
+1 ;FORMAT IS BLRVARS="FIELD NAME_VARIABLE~FIELD NAME_VARIABLE""
+2 ;maw test
KILL BLR,BLRF,BLRFDA
+3 IF $GET(BHLRSLT)="DNR"
QUIT
+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 SET BHLQSIT=$PIECE($GET(^AUTTSITE(1,0)),U)
+11 IF BHLQSIT=""
QUIT
+12 SET BLRPCC=$PIECE($GET(^BLRSITE(BHLQSIT,0)),U,3)
+13 SET (BLRODTM,BLRSEQ,BLRTEST1)=""
SET BLRLINK=1
SET BLRERR=0
SET BHLPHASE="R"
SET BLRCMF="C"
+14 ;after patch 10
SET BLRXPCC=1
+15 SET BHLSEQ=$$GETIEN^BLRFLTL(BLRODTM,BLRSEQ,BLRTEST1)
+16 SET BLRVARS="SEQUENCE NUMBER_BHLSEQ~STATUS FLAG_BHLPHASE~DUZ(2)_BHLLOE~"
+17 SET BLRVARS=BLRVARS_"PATIENT NAME_$G(BHLPNM)~PATIENT POINTER VALUE_$G(BHLPAT)~ACCESSION NUMBER_BHLACC~"
+18 SET BLRVARS=BLRVARS_"ORDERING PROVIDER NAME_$G(BHLORDPE)~ORDERING PROVIDER POINTER_$G(BHLORDPI)~"
+19 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)~"
+20 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)~"
+21 SET BHLLM="CH"
SET BLRVARS=BLRVARS_"LAB MODULE_BHLLM~"
+22 SET BHLIO=$SELECT($GET(BHLIO)]"":BHLIO,1:"E")
SET BLRVARS=BLRVARS_"I/O CATEGORY_BHLIO~"
+23 SET BHLSTAT="R"
SET BLRVARS=BLRVARS_"STATUS FLAG_BHLSTAT~"
+24 SET BHLBILL=1
SET BLRVARS=BLRVARS_"BILLABLE ITEM_BHLBILL~"
+25 SET BHLSRC="R"
SET BLRVARS=BLRVARS_"SOURCE OF DATA INPUT_BHLSRC~"
+26 SET BHLSPC=999
SET BLRVARS=BLRVARS_"SITE/SPECIMEN POINTER_BHLSPC~"
+27 SET BHLSPCE="UNKNOWN"
SET BLRVARS=BLRVARS_"SITE/SPECIMEN NAME_BHLSPCE~"
+28 SET BHLLFLE=2
SET BLRVARS=BLRVARS_"LRFILE_BHLLFLE~"
+29 SET BLRVARS=BLRVARS_"RESULT N/A FLAG_$G(BHLABN)~"
+30 SET BLRVARS=BLRVARS_"BILLING CPT STRING_$G(BHLCPTS)~"
+31 SET BLRVARS=BLRVARS_"HL7 MESSAGE IEN_$G(BHLUIF)"
+32 ;after patch 10
IF '$DATA(BLRF(0))
DO INIT^BLRPARAM
+33 ;I '$D(BLRF(0)) D ^BLRPARAM
+34 ;after patch 10
DO SETVALS^BLRFLTL
+35 ;D ^BLRFLTL("C",BLRVARS) ;before patch 10
+36 ;after patch 10
DO ^BLRNFLTL
+37 QUIT
+38 ;
BUL ;-- file a bulletin if no test match
+1 SET XMB="BHL NO TEST MATCH"
+2 SET XMB(1)=$GET(BHLTST)
SET XMB(2)=$GET(BHLCLTE)
SET XMB(3)=$GET(BHLSEQ)
+3 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 NEW VAR5,BAR6,BHLR
+4 SET BHLR="OBR"
+5 ;collection date
SET VAR5=$$HDATE^INHUT($GET(@BHLTMP@(1,7)),"T")
+6 ;external format
IF $GET(VAR5)
SET VAR5=$$FMTE^XLFDT(VAR5)
+7 ;accession number
SET VAR6=$GET(@BHLTMP@(1,3))
+8 SET XMB(6)=$GET(VAR5)
SET XMB(7)=$GET(VAR6)
+9 DO ^XMB
+10 QUIT
+11 ;
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 ;
RORC ;-- remove orc segments from messge
+1 NEW BHLRDA,BHLCNT,BHLFLG
+2 SET BHLCNT=0
SET BHLFLG=0
+3 SET BHLRDA=0
FOR
SET BHLRDA=$ORDER(^INTHU(UIF,3,BHLRDA))
IF 'BHLRDA
QUIT
Begin DoDot:1
+4 SET BHLCNT=BHLCNT+1
+5 IF $EXTRACT($GET(^INTHU(UIF,3,BHLRDA,0)),1,3)="ORC"
Begin DoDot:2
+6 KILL ^INTHU(UIF,3,BHLRDA,0)
+7 SET BHLCNT=BHLCNT-1
+8 SET BHLFLG=1
End DoDot:2
QUIT
+9 SET ^BHLTMP($JOB,UIF,3,BHLCNT,0)=$GET(^INTHU(UIF,3,BHLRDA,0))
+10 KILL ^INTHU(UIF,3,BHLRDA,0)
End DoDot:1
+11 NEW BHLTDA
+12 SET BHLTDA=0
FOR
SET BHLTDA=$ORDER(^BHLTMP($JOB,UIF,3,BHLTDA))
IF 'BHLTDA
QUIT
Begin DoDot:1
+13 SET ^INTHU(UIF,3,BHLTDA,0)=$GET(^BHLTMP($JOB,UIF,3,BHLTDA,0))
End DoDot:1
+14 QUIT
+15 ;
