BHLRLABI ; cmi/anchorage/maw - BHL ORU/R01 Ref Lab inbound Lab Message ;
;;3.01;BHL IHS Interfaces with GIS;**13,14,16**;AUG 01, 2004
;
;this is the master routine all ref lab inbound are built off of this
;
;this routine will file the inbound dynacare lab message.
;
MAIN ;EP -- this is the main routine driver
S BHLRL=+$G(^BLRSITE(DUZ(2),"RL"))
Q:'$G(BHLRL)
S BHLNOST=1 D ^BHLSETI
;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
Q:$D(BHLERR("FATAL"))
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))
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))
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))
. S BHLTST=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
. S BHLCLTE=$P($G(@BHLTMP@(BHLODA,4)),CS,5)
. S BHLOBSDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,7)),"T")
. S BHLSPDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,14)),"T")
. S BHLORDP=$G(@BHLTMP@(BHLODA,16))
. S BHLRESDT=$$HDATE^INHUT($G(@BHLTMP@(BHLODA,22)),"T")
. S BHLPAR=BHLODA
. D MAP
. I $D(BHL("OBX",BHLODA,2)) D CPT,FILE K BHLCPTS S BHLPSEQ=BHLSEQ
. 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
. S BHLTST=$P($G(@BHLSTMP@(BHLXDA,3)),CS,4)
. S BHLCLTE=$P($G(@BHLSTMP@(BHLXDA,3)),CS,5)
. S BHLRSLT=$G(@BHLSTMP@(BHLXDA,5))
. S BHLUNIT=$G(@BHLSTMP@(BHLXDA,6))
. S BHLREFR=$G(@BHLSTMP@(BHLXDA,7))
. 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
. D FILE
. K BHLCPTS
. 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
. S DIC="^BLRTXLOG("_BHLSEQ_",30,"
. S DA(1)=BHLSEQ,DIC(0)="L",DIC("P")=$P(^DD(9009022,3001,0),"^",2)
. D ^DIC
Q
;
MAP ;-- map the necessary incoming items to rpms
I '$G(BHLORDPI) D
. S BHLORDPI=$O(^VA(200,"ANPI",BHLORDP,0))
S BHLORDPE=$S(BHLORDP'="":$P($G(^DIC(6,BHLORDP,0)),U),1:"")
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 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
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
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(BLRH2(6))~ORDERING PROVIDER POINTER_$G(BLRH2(16))~"
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(BHLODT)~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="A",BLRVARS=BLRVARS_"I/O CATEGORY_BHLIO~"
S BHLSTAT="R",BLRVARS=BLRVARS_"STATUS FLAG_BHLSTAT~"
S BHLBILL=1,BLRVARS=BLRVARS_"BILLABLE ITEM_BHLBILL~"
S BHLSRC=0,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)"
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)
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
;
BHLRLABI ; cmi/anchorage/maw - BHL ORU/R01 Ref Lab inbound Lab Message ;
+1 ;;3.01;BHL IHS Interfaces with GIS;**13,14,16**;AUG 01, 2004
+2 ;
+3 ;this is the master routine all ref lab inbound are built off of this
+4 ;
+5 ;this routine will file the inbound dynacare lab message.
+6 ;
MAIN ;EP -- this is the main routine driver
+1 SET BHLRL=+$GET(^BLRSITE(DUZ(2),"RL"))
+2 IF '$GET(BHLRL)
QUIT
+3 SET BHLNOST=1
DO ^BHLSETI
+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"))
QUIT
+9 DO PRS
+10 DO RFL
+11 DO EOJ
+12 ;jump start the link
DO JOB^BLRPARAM
+13 QUIT
+14 ;
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 BHLDOB=$$HDATE^INHUT($EXTRACT($GET(@BHLTMP@(BHLDA,7)),1,8))
+6 SET BHLSEX=$GET(@BHLTMP@(BHLDA,8))
+7 SET BHLPAT=$$CHKPAT^BHLU(PAT,$GET(DUZ(2)))
+8 IF '$GET(BHLPAT)
SET BHLERCD="NOPAT"
XECUTE BHLERR
+9 IF $DATA(BHLERR("FATAL"))
QUIT
+10 SET BHLPAT=$$CHKDOB^BHLU(BHLPAT)
+11 IF '$GET(BHLPAT)
SET BHLERCD="NOPAT"
XECUTE BHLERR
+12 IF $DATA(BHLERR("FATAL"))
QUIT
+13 SET BHLLOE=$GET(DUZ(2))
+14 QUIT
+15 ;
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 SET BHLTST=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+7 SET BHLCLTE=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,5)
+8 SET BHLOBSDT=$$HDATE^INHUT($GET(@BHLTMP@(BHLODA,7)),"T")
+9 SET BHLSPDT=$$HDATE^INHUT($GET(@BHLTMP@(BHLODA,14)),"T")
+10 SET BHLORDP=$GET(@BHLTMP@(BHLODA,16))
+11 SET BHLRESDT=$$HDATE^INHUT($GET(@BHLTMP@(BHLODA,22)),"T")
+12 SET BHLPAR=BHLODA
+13 DO MAP
+14 IF $DATA(BHL("OBX",BHLODA,2))
DO CPT
DO FILE
KILL BHLCPTS
SET BHLPSEQ=BHLSEQ
+15 IF $DATA(BHLERR("WARNING"))
DO BUL
+16 KILL BHLERR("WARNING")
+17 DO OBX
End DoDot:1
+18 QUIT
+19 ;
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,4)
+6 SET BHLCLTE=$PIECE($GET(@BHLSTMP@(BHLXDA,3)),CS,5)
+7 SET BHLRSLT=$GET(@BHLSTMP@(BHLXDA,5))
+8 SET BHLUNIT=$GET(@BHLSTMP@(BHLXDA,6))
+9 SET BHLREFR=$GET(@BHLSTMP@(BHLXDA,7))
+10 SET BHLREFL=$PIECE($GET(BHLREFR),"-")
+11 SET BHLREFH=$PIECE($GET(BHLREFR),"-",2)
+12 SET BHLABN=$GET(@BHLSTMP@(BHLXDA,8))
+13 SET BHLRESDT=$$HDATE^INHUT($GET(@BHLSTMP@(BHLXDA,14)),"T")
+14 SET BHLSPAR=BHLXDA
+15 DO TESTMAP
+16 IF '$GET(BHLPSEQ)
DO CPT
+17 DO FILE
+18 KILL BHLCPTS
+19 DO NTE
+20 KILL BHLCMT
+21 IF $DATA(BHLERR("WARNING"))
DO BUL
+22 KILL BHLERR("WARNING")
End DoDot:1
+23 QUIT
+24 ;
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
+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 ^DIC
End DoDot:1
+10 QUIT
+11 ;
MAP ;-- map the necessary incoming items to rpms
+1 IF '$GET(BHLORDPI)
Begin DoDot:1
+2 SET BHLORDPI=$ORDER(^VA(200,"ANPI",BHLORDP,0))
End DoDot:1
+3 SET BHLORDPE=$SELECT(BHLORDP'="":$PIECE($GET(^DIC(6,BHLORDP,0)),U),1:"")
+4 SET BHLPNM=$$VAL^XBDIQ1(2,BHLPAT,.01)
+5 SET BHLLOE=$GET(DUZ(2))
TESTMAP ;
+1 SET BHLCLTI=$ORDER(^BLRRL("BTST",BHLTST,BHLRL,0))
+2 IF BHLCLTI=""
SET BHLERCD="NOLCODE"
XECUTE BHLERR
QUIT
+3 SET BHLCLT=$PIECE($GET(^BLRRL(BHLRL,1,BHLCLTI,0)),U,2)
+4 IF BHLCLT=""
SET BHLERCD="NOLAB"
XECUTE BHLERR
+5 QUIT
+6 ;
CPT ;-- let's build the cpt string
+1 IF $GET(BHLPSEQ)
QUIT
+2 IF '$GET(BHLCLT)
QUIT
+3 SET BHLCTST=$ORDER(^BLRCPT("C",BHLCLT,0))
+4 IF BHLCTST=""
QUIT
+5 SET BHLCCNT=0
+6 SET BHLCPTS="|||||"
+7 SET BHLCDA=0
FOR
SET BHLCDA=$ORDER(^BLRCPT(BHLCTST,11,BHLCDA))
IF 'BHLCDA
QUIT
Begin DoDot:1
+8 SET BHLCPT=$PIECE($GET(^BLRCPT(BHLCTST,11,BHLDA,0)),U)
+9 SET BHLCCNT=BHLCCNT+1
+10 SET $PIECE(BHLCPTS,"|",BHLCCNT)=$GET(BHLCPT)
End DoDot:1
+11 QUIT
+12 ;
FILE ;-- file the data in BLRTXLOG
+1 ;FORMAT IS BLRVARS="FIELD NAME_VARIABLE~FIELD NAME_VARIABLE""
+2 ;maw test
KILL BLR,BLRF,BLRFDA
+3 SET BHLQSIT=$PIECE($GET(^AUTTSITE(1,0)),U)
+4 IF BHLQSIT=""
QUIT
+5 SET BLRPCC=$PIECE($GET(^BLRSITE(BHLQSIT,0)),U,3)
+6 SET (BLRODTM,BLRSEQ,BLRTEST1)=""
SET BLRLINK=1
SET BLRERR=0
SET BHLPHASE="R"
SET BLRCMF="C"
+7 ;after patch 10
SET BLRXPCC=1
+8 SET BHLSEQ=$$GETIEN^BLRFLTL(BLRODTM,BLRSEQ,BLRTEST1)
+9 SET BLRVARS="SEQUENCE NUMBER_BHLSEQ~STATUS FLAG_BHLPHASE~DUZ(2)_BHLLOE~"
+10 SET BLRVARS=BLRVARS_"PATIENT NAME_$G(BHLPNM)~PATIENT POINTER VALUE_$G(BHLPAT)~ACCESSION NUMBER_BHLACC~"
+11 SET BLRVARS=BLRVARS_"ORDERING PROVIDER NAME_$G(BLRH2(6))~ORDERING PROVIDER POINTER_$G(BLRH2(16))~"
+12 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)~"
+13 SET BLRVARS=BLRVARS_"PARENT POINTER_$G(BHLPSEQ)~COLLECTION DATE/TIME_BHLOBSDT~ORDER DATE_$G(BHLODT)~ENTRY DATE/TIME_$G(BHLSPDT)~ORDERING LOCATION POINTER_$G(BHLLOC)~ORDERING LOCATION NAME_$G(BHLLOCE)~"
+14 SET BHLLM="CH"
SET BLRVARS=BLRVARS_"LAB MODULE_BHLLM~"
+15 SET BHLIO="A"
SET BLRVARS=BLRVARS_"I/O CATEGORY_BHLIO~"
+16 SET BHLSTAT="R"
SET BLRVARS=BLRVARS_"STATUS FLAG_BHLSTAT~"
+17 SET BHLBILL=1
SET BLRVARS=BLRVARS_"BILLABLE ITEM_BHLBILL~"
+18 SET BHLSRC=0
SET BLRVARS=BLRVARS_"SOURCE OF DATA INPUT_BHLSRC~"
+19 SET BHLSPC=999
SET BLRVARS=BLRVARS_"SITE/SPECIMEN POINTER_BHLSPC~"
+20 SET BHLSPCE="UNKNOWN"
SET BLRVARS=BLRVARS_"SITE/SPECIMEN NAME_BHLSPCE~"
+21 SET BHLLFLE=2
SET BLRVARS=BLRVARS_"LRFILE_BHLLFLE~"
+22 SET BLRVARS=BLRVARS_"RESULT N/A FLAG_$G(BHLABN)~"
+23 SET BLRVARS=BLRVARS_"BILLING CPT STRING_$G(BHLCPTS)"
+24 ;after patch 10
IF '$DATA(BLRF(0))
DO INIT^BLRPARAM
+25 ;I '$D(BLRF(0)) D ^BLRPARAM
+26 ;after patch 10
DO SETVALS^BLRFLTL
+27 ;D ^BLRFLTL("C",BLRVARS) ;before patch 10
+28 ;after patch 10
DO ^BLRNFLTL
+29 QUIT
+30 ;
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 DO ^XMB
+4 QUIT
+5 ;
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 ;
