BLRRLHL2 ;IHS/MSC/MKK - BLR HL7 Utilities for Reference Lab, part 2 ; 09-Mar-2015 06:30 ; MKK
;;5.2;IHS LABORATORY;**1034,1035**;NOV 01, 1997;Build 5
;
; Routines moved here from BLRRLHL because BLRRLHL got too large.
;
Q
;
DX2(PAT) ; EP - Continuation from DX^BLRRLHL
K DIC,BLRDXS,BLRADX,BLRDXA
S BLRADX=1
S DIC="^ICD9("
; S DIC("S")="I '$P($G(^(0)),U,9)"
;
; AICD 4.0 re-did File 80. There is no longer an INACTIVE FLAG.
; STATUS is now a multiple. Note that STATUS=1 is ACTIVE; STATUS=0 is INACTIVE.
; Have to fully specify the global so the $O will work.
S DIC("S")="I $P($G(^ICD9(Y,66,+$O(^ICD9(Y,66,""A""),-1),0)),""^"",2)" ; Most Current Status
;
S DIC(0)="AEMQZ",DIC("A")="What is the ICD Diagnosis code for billing: "
D ^DIC
I Y<0 D Q
. D ADDDX(BLRTSTDA)
. K BLRADX
S BLRDXS=$$ICDDX^ICDEX(+Y)
I $G(BLRDXA(+Y)) D G ENDDX
. W !,"You have already selected this Diagnosis"
;
G:$G(BLRDXS)="" ENDDX ; IHS/MSC/MKK - LR*5.2*1034
;
S BLRDXA(+Y)=1
S BLRDX(DXCNT)=BLRDXS
;
SETDX I '$G(BLRADX) D ADDDX(BLRO) Q
S BLRRL("DX",DXCNT)=$P(BLRDXS,U,2)
S BLRRL("DX")=$P(BLRDXS,U,2)
S DXCNT=DXCNT+1
ENDDX D DX2(BLRRL("PAT"))
Q
;
ADDDX(RO) ;-- add the diagnosis to the test since it is not there, this happens when they want all dx for mult accessions
;ihs/cmi/maw added dx type LR*5.2*1034
N TDA,DXCNT,ORI,TSTDA
S TSTDA=$G(BLRTS)
K BLRRL(TSTDA,"DX")
K BLRRL(TSTDA,"DXE")
K BLRRL(TSTDA,"DXT")
S DXCNT=0
S ORI=$O(^BLRRLO("B",RO,0))
S TDA=0 F S TDA=$O(^BLRRLO(ORI,1,TDA)) Q:'TDA D
. N DXS
. S DXCNT=DXCNT+1
. ;S DXS=$G(BLRDX(TDA))
. S DXS=$S($D(^ICDS(0)):$$ICDDX^ICDEX($P($G(^BLRRLO(ORI,1,TDA,0)),U)),1:$$ICDDX^ICDCODE($P($G(^BLRRLO(ORI,1,TDA,0)),U)))
. S BLRRL("DX",DXCNT)=$P(DXS,U,2)
. S BLRRL("DX")=$P(DXS,U,2)
. S BLRRL(TSTDA,"DX",TDA)=$P(DXS,U,2)
. S BLRRL(TSTDA,"DXE",TDA)=$P(DXS,U,4)
. S BLRRL(TSTDA,"DXT",TDA)=$S($P(DXS,U,20)'=30:"I9",1:"I10")
. S BLRRL(TSTDA,"DX")=$P(DXS,U,2) ;cmi/maw 01/20/2010
. S BLRRL(TSTDA,"DXE")=$P(DXS,U,4) ;cmi/maw 01/20/2010
. S BLRRL(TSTDA,"DXT")=$S($P(DXS,U,20)'=30:"I9",1:"I10") ;cmi/maw 01/20/2010
Q
;
HLSET(BLRINS) ;-- setup hl7 variables
S INSCNT=BLRINS
S BLRRL(BLRTSTDA,"INSE",INSCNT)=$P(AGINS(BLRINS),U)
S BLRRL("INSE",INSCNT)=$P(AGINS(BLRINS),U)
S BLRRL(BLRTSTDA,"INSI",INSCNT)=$P(AGINS(BLRINS),U,2)
;S BLRRL(BLRTSTDA,"INSCOV")=$P(AGINS(BLRINS),U,4)
S BLRRL(BLRTSTDA,"INSCOV",INSCNT)=$E($G(BLRRL("BILL TYPE")),1,1)
S BLRRL(BLRTSTDA,"INSPH",INSCNT)=$P(AGINS(BLRINS),U,7)
S BLRRL(BLRTSTDA,"INSGRP",INSCNT)=$P(AGINS(BLRINS),U,20)
S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S($P(AGINS(BLRINS),U,16):$P($G(^AUTTRLSH($P(AGINS(BLRINS),U,16),0)),U),1:"")
S BLRRL(BLRTSTDA,"INSRELE",INSCNT)=BLRRL(BLRTSTDA,"INSREL",INSCNT)
I $G(BLRRL(BLRTSTDA,"INSREL",INSCNT))]"" D
. I BLRRL(BLRTSTDA,"INSREL",INSCNT)="SELF" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:1) Q
. I BLRRL(BLRTSTDA,"INSREL",INSCNT)="SPOUSE" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE" Q
. I BLRRL(BLRTSTDA,"INSREL",INSCNT)="HUSBAND" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE" Q
. I BLRRL(BLRTSTDA,"INSREL",INSCNT)="WIFE" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE" Q
. S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":8,1:3),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="OTHER" Q
I $G(BLRRL(BLRTSTDA,"INSREL",INSCNT))="" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":1,1:1),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SELF"
S BLRRL(BLRTSTDA,"INSPOL",INSCNT)=$P(AGINS(BLRINS),U,9)
S BLRRL(BLRTSTDA,"INSELG",INSCNT)=$P(AGINS(BLRINS),U,5)
S BLRRL(BLRTSTDA,"INSEXP",INSCNT)=$P(AGINS(BLRINS),U,6)
S BLRRL(BLRTSTDA,"INSPLN",INSCNT)=$S(BLRRL(BLRTSTDA,"INSE",INSCNT)["MEDICARE":"MC",BLRRL(BLRTSTDA,"INSE",INSCNT)["MEDICAID":"MD",1:"PI")
S BLRRL(BLRTSTDA,"INSTYP",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),2)),U)
I BLRRL(BLRTSTDA,"INSI",INSCNT)]"" D
. S BLRRL(BLRTSTDA,"INSID",INSCNT)=$TR($P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),2)),U,19),"~") ;cmi/maw 2/17/2009 changed to piece 10 external group name from external id 2
. S BLRRL(BLRTSTDA,"INSCNME",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),0)),U) ;insurance company name
. S BLRRL(BLRTSTDA,"INSADD",INSCNT)=$$INSADD^BLRRLHL(BLRRL(BLRTSTDA,"INSI",INSCNT))
. S BLRRL(BLRTSTDA,"INSADDE",INSCNT)=$TR($P(BLRRL(BLRTSTDA,"INSADD",INSCNT),U),U," ")_"~"_$TR($P(BLRRL(BLRTSTDA,"INSADD",INSCNT),U,3,99),U," ")
. S BLRRL(BLRTSTDA,"INSPHO",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),0)),U,6)
. S BLRRL(BLRTSTDA,"INSTYP",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U)
S BLRRL(BLRTSTDA,"INSEMP",INSCNT)=$$GET1^DIQ(2,PAT,.3111)
S BLRRL(BLRTSTDA,"INSNOI",INSCNT)=$$HLNAME^XLFNAME($P(^DPT(PAT,0),U))
S BLRRL(BLRTSTDA,"INSNOIE",INSCNT)=$P(^DPT(PAT,0),U)
S INSCNT=INSCNT+1
;end of hl7 lines
Q
;
O01(BHL) ;PEP - Order Message
;ihs/cmi/maw - added this sub from BHLEVENT so can be update by lab without GIS patch LR*5.2*1034
K INDA,INA
I '$G(BHL("PAT")) Q $$MSG(0)
S INDA=BHL("PAT")
S INA("DUZ2")=$S($G(BHL("ALTDUZ2")):BHL("ALTDUZ2"),1:DUZ(2)) ;cmi/maw 4/25/2006 DUZ(2) gets reset by GIS
;cmi/maw 4/25/2006 changed below code due to lapcorp inadequacy
I BHL("RLE")'="LABCORP" S INA("SF")=$G(BHL("CLIENT")) ;maw 3/3/2006 dynamic account number in MSH
S INA("PID20LABO",1)=$G(BHL("CLIENT"))_"^^^"_$S($E($G(BHL("BILL TYPE")),1,1)="T":$G(BHL("INSTYP")),$E($G(BHL("BILL TYPE")),1,1)="P":"P",1:"C") ;quest client id
I BHL("RLE")="LABCORP" S INA("PID20LABO",1)=$G(BHL("CLIENT"))_"^^^"_$S($E($G(BHL("BILL TYPE")),1,1)="T":"T",$E($G(BHL("BILL TYPE")),1,1)="P":"P",1:"C") ;labcorp client id
S INA("ORC2LABO")=$G(BHL("UID"))
S INA("ORC12LABO")=$G(BHL("ORDP"))
S INA("ORC11LABO")=$$DATE^INHUT($G(BHL("CDT")),1)
S BHLDA=0 F S BHLDA=$O(BHL(BHLDA)) Q:'BHLDA D
. S INA("ORC2LABO",BHLDA)=$G(BHL("UID"))
. S INA("ORC11LABO",BHLDA)=$G(BHL(BHLDA,"CDT"))
. S INA("ORC12LABO",BHLDA)=$G(BHL(BHLDA,"ORDP"))
. S INA("OBR4LABO",BHLDA)=U_U_U_$G(BHL(BHLDA,"TCNM"))
. S INA("OBR4LABOL",BHLDA)=$G(BHL(BHLDA,"TCNM"))
. S INA("OBR7LABO",BHLDA)=$G(BHL(BHLDA,"CDT"))
. S INA("OBR13LABO",BHLDA)="N"
. S INA("OBR15LABO",BHLDA)=$G(BHL(BHLDA,"SRC"))
. S INA("OBR18LC",BHLDA)=$G(BHL(BHLDA,"ORD"))
. S INA("OBR27LABO",BHLDA)="^^^^^"_$S($G(BHL("URG"))=1:"S",$G(BHL("URG"))=10:"A",1:"R")
. N IDA
. S IDA=0 F S IDA=$O(BHL(BHLDA,"INSE",IDA)) Q:'IDA D
.. S INDA("IN1",IDA)=""
.. S INA("IN13LABO",IDA)=$S($G(BHL("RLE"))="LABCORP":U_$G(BHL(BHLDA,"INSID",IDA)),1:$G(BHL(BHLDA,"INSID",IDA)))
.. S INA("IN14LABO",IDA)=$G(BHL(BHLDA,"INSE",IDA))
.. S INA("IN15LABO",IDA)=$G(BHL(BHLDA,"INSADD",IDA))
.. S INA("IN17LABO",IDA)=$G(BHL(BHLDA,"INSPHO",IDA))
.. S INA("IN18LABO",IDA)=$G(BHL(BHLDA,"INSGRP",IDA))
.. S INA("IN111LABO",IDA)=$G(BHL(BHLDA,"INSEMP",IDA))
.. S INA("IN112LABO",IDA)=$$DATE^INHUT($G(BHL(BHLDA,"INSELG",IDA)),1)
.. S INA("IN113LABO",IDA)=$$DATE^INHUT($G(BHL(BHLDA,"INSEXP",IDA)),1)
.. S INA("IN115LABO",IDA)=$G(BHL(BHLDA,"INSPLN",IDA))
.. S INA("IN116LABO",IDA)=$G(BHL(BHLDA,"INSNOI",IDA))
.. S INA("IN117LABO",IDA)=$G(BHL(BHLDA,"INSREL",IDA))
.. S INA("IN119LABO",IDA)=$G(BHL(BHLDA,"INSADD",IDA))
.. S INA("IN136LABO",IDA)=$G(BHL(BHLDA,"INSPOL",IDA))
.. S INA("IN147LABO",IDA)=$S($G(BHL(BHLDA,"INSCOV",IDA))]"":$E(BHL(BHLDA,"INSCOV",IDA),1,1),1:"C")
. S INA("GT13LABO",BHLDA)=$G(BHL(BHLDA,"GT1NM"))
. S INA("GT15LABO",BHLDA)=$G(BHL(BHLDA,"GT1ADD"))
. S INA("GT16LABO",BHLDA)=$G(BHL(BHLDA,"GT1PHO"))
. ;cmi/maw 4/4/2008 end of insurance info
. ;cmi/maw 4/4/2008 beginning of dx
. S INA("GT13LABO")=$G(BHL(BHLDA,"GT1NM"))
. S INA("GT15LABO")=$G(BHL(BHLDA,"GT1ADD"))
. S INA("GT16LABO")=$G(BHL(BHLDA,"GT1PHO"))
. ;cmi/maw 4/4/2008 end of insurance info
. ;cmi/maw 4/4/2008 beginning of dx
. N DGDA
. S DGDA=0 F S DGDA=$O(BHL(BHLDA,"DX",DGDA)) Q:'DGDA D
.. S INDA("DG1",DGDA)=""
.. S INA("DG12LABO",DGDA)=$G(BHL(BHLDA,"DXT",DGDA))
.. S INA("DG13LABO",DGDA)=$G(BHL(BHLDA,"DX",DGDA))_U_$G(BHL(BHLDA,"DXE",DGDA))_U_$G(BHL(BHLDA,"DXT",DGDA))
.. I BHL("RLE")'="LABCORP" S INA("DG13LABO",DGDA)=$G(BHL(BHLDA,"DX",DGDA))
.. S INA("DG14LABO",DGDA)=$G(BHL(BHLDA,"DXE",DGDA))
.. S INA("DG12LABO")=$G(BHL(BHLDA,"DXT",DGDA))
.. S INA("DG13LABO")=$G(BHL(BHLDA,"DX",DGDA))_U_$G(BHL(BHLDA,"DXE",DGDA))_U_$G(BHL(BHLDA,"DXT",DGDA))
.. I BHL("RLE")'="LABCORP" S INA("DG13LABO",DGDA)=$G(BHL(BHLDA,"DX",DGDA))
.. S INA("DG14LABO")=$G(BHL(BHLDA,"DXE",DGDA))
. ;cmi/maw 4/4/2008 end of dx
. S INDA("ORC",BHLDA)=""
. S INDA("OBR",BHLDA)=""
. S BHLCDA=0 F S BHLCDA=$O(BHL(BHLDA,"COMMENT",BHLCDA)) Q:'BHLCDA D
.. S INDA("OBX",BHLCDA)=""
.. S BHLCOM1=$P(BHL(BHLDA,"COMMENT",BHLCDA),U)
.. S BHLCOM2=$P(BHL(BHLDA,"COMMENT",BHLCDA),U,2)
.. S BHLCOM3=$P(BHL(BHLDA,"COMMENT",BHLCDA),U,3)
.. S INA("OBX3LABO",BHLDA,BHLCDA)=U_U_U_BHLCOM1_U_BHLCOM2
.. S INA("OBX2LABOL",BHLDA,BHLCDA)="ST"
.. S INA("OBX3LABOL1",BHLDA,BHLCDA)=BHLCOM1
.. S INA("OBX3LABOL2",BHLDA,BHLCDA)=BHLCOM2
.. S INA("OBX14LABO",BHLDA,BHLCDA)=$G(BHL("CDT"))
.. S INA("OBX5LABO",BHLDA,BHLCDA)=BHLCOM3
.. S INA("OBX3LABLC3",BHLDA,BHLCDA)=$G(BHL("RLE"))
S INA("ORC2LABO")=$G(BHL("UID"))
S INA("ORC11LABO")=$G(BHL("CDT"))
S INA("ORC12LABO")=$G(BHL("ORDP"))
S INA("OBR4LABO")=U_U_U_$G(BHL("TCNM"))
S INA("OBR4LABOL")=$G(BHL("TCNM"))
S INA("OBR7LABO")=$G(BHL("CDT"))
S INA("OBR13LABO")="N"
S INA("OBR27LABO")="^^^^^"_$S($G(BHL("URG"))=1:"S",$G(BHL("URG"))=10:"A",1:"R")
S INDA("ORC")=""
S INDA("OBR")=""
S BHLCDA=0 F S BHLCDA=$O(BHL("COMMENT",BHLCDA)) Q:'BHLCDA D
. S INDA("OBX",BHLCDA)=""
. S BHLCOM1=$P(BHL("COMMENT",BHLCDA),U)
. S BHLCOM2=$P(BHL("COMMENT",BHLCDA),U,2)
. S BHLCOM3=$P(BHL("COMMENT",BHLCDA),U,3)
. S INA("OBX2LABOL",BHLCDA)="ST"
. S INA("OBX3LABOL1",BHLCDA)=BHLCOM1
. S INA("OBX3LABOL2",BHLCDA)=BHLCOM2
. S INA("OBX14LABO",BHLCDA)=$G(BHL("CDT"))
. S INA("OBX3LABO",BHLCDA)=U_U_U_BHLCOM1_U_BHLCOM2
. S INA("OBX5LABO",BHLCDA)=BHLCOM3
. S INA("OBX3LABLC3",BHLCDA)=$G(BHL("RLE"))
D ^INHF("HL IHS O01 OUT PARENT",.INDA,.INA)
Q $$MSG(INHF)
;
MSG(BHLMVAR) ;-- return message defining status
I BHLMVAR="PAT" S BHLRMSG="Patient Not Passed In, Message Not Created"
I BHLMVAR="VST" S BHLRMSG="Visit Not Passed In, Message Not Created"
I BHLMVAR="VLAB" S BHLRMSG="VLAB Not Passed In, Message Not Created"
I BHLMVAR="MFL" S BHLRMSG="Mstr File Not Passed In, Message Not Created"
I BHLMVAR=0 S BHLRMSG="Message Not Created, problem with GIS call"
I BHLMVAR S BHLRMSG=BHLMVAR_U_"Message Created Successfully"
Q $G(BHLRMSG)
;
BLRRLHL2 ;IHS/MSC/MKK - BLR HL7 Utilities for Reference Lab, part 2 ; 09-Mar-2015 06:30 ; MKK
+1 ;;5.2;IHS LABORATORY;**1034,1035**;NOV 01, 1997;Build 5
+2 ;
+3 ; Routines moved here from BLRRLHL because BLRRLHL got too large.
+4 ;
+5 QUIT
+6 ;
DX2(PAT) ; EP - Continuation from DX^BLRRLHL
+1 KILL DIC,BLRDXS,BLRADX,BLRDXA
+2 SET BLRADX=1
+3 SET DIC="^ICD9("
+4 ; S DIC("S")="I '$P($G(^(0)),U,9)"
+5 ;
+6 ; AICD 4.0 re-did File 80. There is no longer an INACTIVE FLAG.
+7 ; STATUS is now a multiple. Note that STATUS=1 is ACTIVE; STATUS=0 is INACTIVE.
+8 ; Have to fully specify the global so the $O will work.
+9 ; Most Current Status
SET DIC("S")="I $P($G(^ICD9(Y,66,+$O(^ICD9(Y,66,""A""),-1),0)),""^"",2)"
+10 ;
+11 SET DIC(0)="AEMQZ"
SET DIC("A")="What is the ICD Diagnosis code for billing: "
+12 DO ^DIC
+13 IF Y<0
Begin DoDot:1
+14 DO ADDDX(BLRTSTDA)
+15 KILL BLRADX
End DoDot:1
QUIT
+16 SET BLRDXS=$$ICDDX^ICDEX(+Y)
+17 IF $GET(BLRDXA(+Y))
Begin DoDot:1
+18 WRITE !,"You have already selected this Diagnosis"
End DoDot:1
GOTO ENDDX
+19 ;
+20 ; IHS/MSC/MKK - LR*5.2*1034
IF $GET(BLRDXS)=""
GOTO ENDDX
+21 ;
+22 SET BLRDXA(+Y)=1
+23 SET BLRDX(DXCNT)=BLRDXS
+24 ;
SETDX IF '$GET(BLRADX)
DO ADDDX(BLRO)
QUIT
+1 SET BLRRL("DX",DXCNT)=$PIECE(BLRDXS,U,2)
+2 SET BLRRL("DX")=$PIECE(BLRDXS,U,2)
+3 SET DXCNT=DXCNT+1
ENDDX DO DX2(BLRRL("PAT"))
+1 QUIT
+2 ;
ADDDX(RO) ;-- add the diagnosis to the test since it is not there, this happens when they want all dx for mult accessions
+1 ;ihs/cmi/maw added dx type LR*5.2*1034
+2 NEW TDA,DXCNT,ORI,TSTDA
+3 SET TSTDA=$GET(BLRTS)
+4 KILL BLRRL(TSTDA,"DX")
+5 KILL BLRRL(TSTDA,"DXE")
+6 KILL BLRRL(TSTDA,"DXT")
+7 SET DXCNT=0
+8 SET ORI=$ORDER(^BLRRLO("B",RO,0))
+9 SET TDA=0
FOR
SET TDA=$ORDER(^BLRRLO(ORI,1,TDA))
IF 'TDA
QUIT
Begin DoDot:1
+10 NEW DXS
+11 SET DXCNT=DXCNT+1
+12 ;S DXS=$G(BLRDX(TDA))
+13 SET DXS=$SELECT($DATA(^ICDS(0)):$$ICDDX^ICDEX($PIECE($GET(^BLRRLO(ORI,1,TDA,0)),U)),1:$$ICDDX^ICDCODE($PIECE($GET(^BLRRLO(ORI,1,TDA,0)),U)))
+14 SET BLRRL("DX",DXCNT)=$PIECE(DXS,U,2)
+15 SET BLRRL("DX")=$PIECE(DXS,U,2)
+16 SET BLRRL(TSTDA,"DX",TDA)=$PIECE(DXS,U,2)
+17 SET BLRRL(TSTDA,"DXE",TDA)=$PIECE(DXS,U,4)
+18 SET BLRRL(TSTDA,"DXT",TDA)=$SELECT($PIECE(DXS,U,20)'=30:"I9",1:"I10")
+19 ;cmi/maw 01/20/2010
SET BLRRL(TSTDA,"DX")=$PIECE(DXS,U,2)
+20 ;cmi/maw 01/20/2010
SET BLRRL(TSTDA,"DXE")=$PIECE(DXS,U,4)
+21 ;cmi/maw 01/20/2010
SET BLRRL(TSTDA,"DXT")=$SELECT($PIECE(DXS,U,20)'=30:"I9",1:"I10")
End DoDot:1
+22 QUIT
+23 ;
HLSET(BLRINS) ;-- setup hl7 variables
+1 SET INSCNT=BLRINS
+2 SET BLRRL(BLRTSTDA,"INSE",INSCNT)=$PIECE(AGINS(BLRINS),U)
+3 SET BLRRL("INSE",INSCNT)=$PIECE(AGINS(BLRINS),U)
+4 SET BLRRL(BLRTSTDA,"INSI",INSCNT)=$PIECE(AGINS(BLRINS),U,2)
+5 ;S BLRRL(BLRTSTDA,"INSCOV")=$P(AGINS(BLRINS),U,4)
+6 SET BLRRL(BLRTSTDA,"INSCOV",INSCNT)=$EXTRACT($GET(BLRRL("BILL TYPE")),1,1)
+7 SET BLRRL(BLRTSTDA,"INSPH",INSCNT)=$PIECE(AGINS(BLRINS),U,7)
+8 SET BLRRL(BLRTSTDA,"INSGRP",INSCNT)=$PIECE(AGINS(BLRINS),U,20)
+9 SET BLRRL(BLRTSTDA,"INSREL",INSCNT)=$SELECT($PIECE(AGINS(BLRINS),U,16):$PIECE($GET(^AUTTRLSH($PIECE(AGINS(BLRINS),U,16),0)),U),1:"")
+10 SET BLRRL(BLRTSTDA,"INSRELE",INSCNT)=BLRRL(BLRTSTDA,"INSREL",INSCNT)
+11 IF $GET(BLRRL(BLRTSTDA,"INSREL",INSCNT))]""
Begin DoDot:1
+12 IF BLRRL(BLRTSTDA,"INSREL",INSCNT)="SELF"
SET BLRRL(BLRTSTDA,"INSREL",INSCNT)=$SELECT(BLRRL("RLE")["QUEST":2,1:1)
QUIT
+13 IF BLRRL(BLRTSTDA,"INSREL",INSCNT)="SPOUSE"
SET BLRRL(BLRTSTDA,"INSREL",INSCNT)=$SELECT(BLRRL("RLE")["QUEST":2,1:2)
SET BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE"
QUIT
+14 IF BLRRL(BLRTSTDA,"INSREL",INSCNT)="HUSBAND"
SET BLRRL(BLRTSTDA,"INSREL",INSCNT)=$SELECT(BLRRL("RLE")["QUEST":2,1:2)
SET BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE"
QUIT
+15 IF BLRRL(BLRTSTDA,"INSREL",INSCNT)="WIFE"
SET BLRRL(BLRTSTDA,"INSREL",INSCNT)=$SELECT(BLRRL("RLE")["QUEST":2,1:2)
SET BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE"
QUIT
+16 SET BLRRL(BLRTSTDA,"INSREL",INSCNT)=$SELECT(BLRRL("RLE")["QUEST":8,1:3)
SET BLRRL(BLRTSTDA,"INSRELE",INSCNT)="OTHER"
QUIT
End DoDot:1
+17 IF $GET(BLRRL(BLRTSTDA,"INSREL",INSCNT))=""
SET BLRRL(BLRTSTDA,"INSREL",INSCNT)=$SELECT(BLRRL("RLE")["QUEST":1,1:1)
SET BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SELF"
+18 SET BLRRL(BLRTSTDA,"INSPOL",INSCNT)=$PIECE(AGINS(BLRINS),U,9)
+19 SET BLRRL(BLRTSTDA,"INSELG",INSCNT)=$PIECE(AGINS(BLRINS),U,5)
+20 SET BLRRL(BLRTSTDA,"INSEXP",INSCNT)=$PIECE(AGINS(BLRINS),U,6)
+21 SET BLRRL(BLRTSTDA,"INSPLN",INSCNT)=$SELECT(BLRRL(BLRTSTDA,"INSE",INSCNT)["MEDICARE":"MC",BLRRL(BLRTSTDA,"INSE",INSCNT)["MEDICAID":"MD",1:"PI")
+22 SET BLRRL(BLRTSTDA,"INSTYP",INSCNT)=$PIECE($GET(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),2)),U)
+23 IF BLRRL(BLRTSTDA,"INSI",INSCNT)]""
Begin DoDot:1
+24 ;cmi/maw 2/17/2009 changed to piece 10 external group name from external id 2
SET BLRRL(BLRTSTDA,"INSID",INSCNT)=$TRANSLATE($PIECE($GET(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),2)),U,19),"~")
+25 ;insurance company name
SET BLRRL(BLRTSTDA,"INSCNME",INSCNT)=$PIECE($GET(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),0)),U)
+26 SET BLRRL(BLRTSTDA,"INSADD",INSCNT)=$$INSADD^BLRRLHL(BLRRL(BLRTSTDA,"INSI",INSCNT))
+27 SET BLRRL(BLRTSTDA,"INSADDE",INSCNT)=$TRANSLATE($PIECE(BLRRL(BLRTSTDA,"INSADD",INSCNT),U),U," ")_"~"_$TRANSLATE($PIECE(BLRRL(BLRTSTDA,"INSADD",INSCNT),U,3,99),U," ")
+28 SET BLRRL(BLRTSTDA,"INSPHO",INSCNT)=$PIECE($GET(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),0)),U,6)
+29 SET BLRRL(BLRTSTDA,"INSTYP",INSCNT)=$PIECE($GET(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U)
End DoDot:1
+30 SET BLRRL(BLRTSTDA,"INSEMP",INSCNT)=$$GET1^DIQ(2,PAT,.3111)
+31 SET BLRRL(BLRTSTDA,"INSNOI",INSCNT)=$$HLNAME^XLFNAME($PIECE(^DPT(PAT,0),U))
+32 SET BLRRL(BLRTSTDA,"INSNOIE",INSCNT)=$PIECE(^DPT(PAT,0),U)
+33 SET INSCNT=INSCNT+1
+34 ;end of hl7 lines
+35 QUIT
+36 ;
O01(BHL) ;PEP - Order Message
+1 ;ihs/cmi/maw - added this sub from BHLEVENT so can be update by lab without GIS patch LR*5.2*1034
+2 KILL INDA,INA
+3 IF '$GET(BHL("PAT"))
QUIT $$MSG(0)
+4 SET INDA=BHL("PAT")
+5 ;cmi/maw 4/25/2006 DUZ(2) gets reset by GIS
SET INA("DUZ2")=$SELECT($GET(BHL("ALTDUZ2")):BHL("ALTDUZ2"),1:DUZ(2))
+6 ;cmi/maw 4/25/2006 changed below code due to lapcorp inadequacy
+7 ;maw 3/3/2006 dynamic account number in MSH
IF BHL("RLE")'="LABCORP"
SET INA("SF")=$GET(BHL("CLIENT"))
+8 ;quest client id
SET INA("PID20LABO",1)=$GET(BHL("CLIENT"))_"^^^"_$SELECT($EXTRACT($GET(BHL("BILL TYPE")),1,1)="T":$GET(BHL("INSTYP")),$EXTRACT($GET(BHL("BILL TYPE")),1,1)="P":"P",1:"C")
+9 ;labcorp client id
IF BHL("RLE")="LABCORP"
SET INA("PID20LABO",1)=$GET(BHL("CLIENT"))_"^^^"_$SELECT($EXTRACT($GET(BHL("BILL TYPE")),1,1)="T":"T",$EXTRACT($GET(BHL("BILL TYPE")),1,1)="P":"P",1:"C")
+10 SET INA("ORC2LABO")=$GET(BHL("UID"))
+11 SET INA("ORC12LABO")=$GET(BHL("ORDP"))
+12 SET INA("ORC11LABO")=$$DATE^INHUT($GET(BHL("CDT")),1)
+13 SET BHLDA=0
FOR
SET BHLDA=$ORDER(BHL(BHLDA))
IF 'BHLDA
QUIT
Begin DoDot:1
+14 SET INA("ORC2LABO",BHLDA)=$GET(BHL("UID"))
+15 SET INA("ORC11LABO",BHLDA)=$GET(BHL(BHLDA,"CDT"))
+16 SET INA("ORC12LABO",BHLDA)=$GET(BHL(BHLDA,"ORDP"))
+17 SET INA("OBR4LABO",BHLDA)=U_U_U_$GET(BHL(BHLDA,"TCNM"))
+18 SET INA("OBR4LABOL",BHLDA)=$GET(BHL(BHLDA,"TCNM"))
+19 SET INA("OBR7LABO",BHLDA)=$GET(BHL(BHLDA,"CDT"))
+20 SET INA("OBR13LABO",BHLDA)="N"
+21 SET INA("OBR15LABO",BHLDA)=$GET(BHL(BHLDA,"SRC"))
+22 SET INA("OBR18LC",BHLDA)=$GET(BHL(BHLDA,"ORD"))
+23 SET INA("OBR27LABO",BHLDA)="^^^^^"_$SELECT($GET(BHL("URG"))=1:"S",$GET(BHL("URG"))=10:"A",1:"R")
+24 NEW IDA
+25 SET IDA=0
FOR
SET IDA=$ORDER(BHL(BHLDA,"INSE",IDA))
IF 'IDA
QUIT
Begin DoDot:2
+26 SET INDA("IN1",IDA)=""
+27 SET INA("IN13LABO",IDA)=$SELECT($GET(BHL("RLE"))="LABCORP":U_$GET(BHL(BHLDA,"INSID",IDA)),1:$GET(BHL(BHLDA,"INSID",IDA)))
+28 SET INA("IN14LABO",IDA)=$GET(BHL(BHLDA,"INSE",IDA))
+29 SET INA("IN15LABO",IDA)=$GET(BHL(BHLDA,"INSADD",IDA))
+30 SET INA("IN17LABO",IDA)=$GET(BHL(BHLDA,"INSPHO",IDA))
+31 SET INA("IN18LABO",IDA)=$GET(BHL(BHLDA,"INSGRP",IDA))
+32 SET INA("IN111LABO",IDA)=$GET(BHL(BHLDA,"INSEMP",IDA))
+33 SET INA("IN112LABO",IDA)=$$DATE^INHUT($GET(BHL(BHLDA,"INSELG",IDA)),1)
+34 SET INA("IN113LABO",IDA)=$$DATE^INHUT($GET(BHL(BHLDA,"INSEXP",IDA)),1)
+35 SET INA("IN115LABO",IDA)=$GET(BHL(BHLDA,"INSPLN",IDA))
+36 SET INA("IN116LABO",IDA)=$GET(BHL(BHLDA,"INSNOI",IDA))
+37 SET INA("IN117LABO",IDA)=$GET(BHL(BHLDA,"INSREL",IDA))
+38 SET INA("IN119LABO",IDA)=$GET(BHL(BHLDA,"INSADD",IDA))
+39 SET INA("IN136LABO",IDA)=$GET(BHL(BHLDA,"INSPOL",IDA))
+40 SET INA("IN147LABO",IDA)=$SELECT($GET(BHL(BHLDA,"INSCOV",IDA))]"":$EXTRACT(BHL(BHLDA,"INSCOV",IDA),1,1),1:"C")
End DoDot:2
+41 SET INA("GT13LABO",BHLDA)=$GET(BHL(BHLDA,"GT1NM"))
+42 SET INA("GT15LABO",BHLDA)=$GET(BHL(BHLDA,"GT1ADD"))
+43 SET INA("GT16LABO",BHLDA)=$GET(BHL(BHLDA,"GT1PHO"))
+44 ;cmi/maw 4/4/2008 end of insurance info
+45 ;cmi/maw 4/4/2008 beginning of dx
+46 SET INA("GT13LABO")=$GET(BHL(BHLDA,"GT1NM"))
+47 SET INA("GT15LABO")=$GET(BHL(BHLDA,"GT1ADD"))
+48 SET INA("GT16LABO")=$GET(BHL(BHLDA,"GT1PHO"))
+49 ;cmi/maw 4/4/2008 end of insurance info
+50 ;cmi/maw 4/4/2008 beginning of dx
+51 NEW DGDA
+52 SET DGDA=0
FOR
SET DGDA=$ORDER(BHL(BHLDA,"DX",DGDA))
IF 'DGDA
QUIT
Begin DoDot:2
+53 SET INDA("DG1",DGDA)=""
+54 SET INA("DG12LABO",DGDA)=$GET(BHL(BHLDA,"DXT",DGDA))
+55 SET INA("DG13LABO",DGDA)=$GET(BHL(BHLDA,"DX",DGDA))_U_$GET(BHL(BHLDA,"DXE",DGDA))_U_$GET(BHL(BHLDA,"DXT",DGDA))
+56 IF BHL("RLE")'="LABCORP"
SET INA("DG13LABO",DGDA)=$GET(BHL(BHLDA,"DX",DGDA))
+57 SET INA("DG14LABO",DGDA)=$GET(BHL(BHLDA,"DXE",DGDA))
+58 SET INA("DG12LABO")=$GET(BHL(BHLDA,"DXT",DGDA))
+59 SET INA("DG13LABO")=$GET(BHL(BHLDA,"DX",DGDA))_U_$GET(BHL(BHLDA,"DXE",DGDA))_U_$GET(BHL(BHLDA,"DXT",DGDA))
+60 IF BHL("RLE")'="LABCORP"
SET INA("DG13LABO",DGDA)=$GET(BHL(BHLDA,"DX",DGDA))
+61 SET INA("DG14LABO")=$GET(BHL(BHLDA,"DXE",DGDA))
End DoDot:2
+62 ;cmi/maw 4/4/2008 end of dx
+63 SET INDA("ORC",BHLDA)=""
+64 SET INDA("OBR",BHLDA)=""
+65 SET BHLCDA=0
FOR
SET BHLCDA=$ORDER(BHL(BHLDA,"COMMENT",BHLCDA))
IF 'BHLCDA
QUIT
Begin DoDot:2
+66 SET INDA("OBX",BHLCDA)=""
+67 SET BHLCOM1=$PIECE(BHL(BHLDA,"COMMENT",BHLCDA),U)
+68 SET BHLCOM2=$PIECE(BHL(BHLDA,"COMMENT",BHLCDA),U,2)
+69 SET BHLCOM3=$PIECE(BHL(BHLDA,"COMMENT",BHLCDA),U,3)
+70 SET INA("OBX3LABO",BHLDA,BHLCDA)=U_U_U_BHLCOM1_U_BHLCOM2
+71 SET INA("OBX2LABOL",BHLDA,BHLCDA)="ST"
+72 SET INA("OBX3LABOL1",BHLDA,BHLCDA)=BHLCOM1
+73 SET INA("OBX3LABOL2",BHLDA,BHLCDA)=BHLCOM2
+74 SET INA("OBX14LABO",BHLDA,BHLCDA)=$GET(BHL("CDT"))
+75 SET INA("OBX5LABO",BHLDA,BHLCDA)=BHLCOM3
+76 SET INA("OBX3LABLC3",BHLDA,BHLCDA)=$GET(BHL("RLE"))
End DoDot:2
End DoDot:1
+77 SET INA("ORC2LABO")=$GET(BHL("UID"))
+78 SET INA("ORC11LABO")=$GET(BHL("CDT"))
+79 SET INA("ORC12LABO")=$GET(BHL("ORDP"))
+80 SET INA("OBR4LABO")=U_U_U_$GET(BHL("TCNM"))
+81 SET INA("OBR4LABOL")=$GET(BHL("TCNM"))
+82 SET INA("OBR7LABO")=$GET(BHL("CDT"))
+83 SET INA("OBR13LABO")="N"
+84 SET INA("OBR27LABO")="^^^^^"_$SELECT($GET(BHL("URG"))=1:"S",$GET(BHL("URG"))=10:"A",1:"R")
+85 SET INDA("ORC")=""
+86 SET INDA("OBR")=""
+87 SET BHLCDA=0
FOR
SET BHLCDA=$ORDER(BHL("COMMENT",BHLCDA))
IF 'BHLCDA
QUIT
Begin DoDot:1
+88 SET INDA("OBX",BHLCDA)=""
+89 SET BHLCOM1=$PIECE(BHL("COMMENT",BHLCDA),U)
+90 SET BHLCOM2=$PIECE(BHL("COMMENT",BHLCDA),U,2)
+91 SET BHLCOM3=$PIECE(BHL("COMMENT",BHLCDA),U,3)
+92 SET INA("OBX2LABOL",BHLCDA)="ST"
+93 SET INA("OBX3LABOL1",BHLCDA)=BHLCOM1
+94 SET INA("OBX3LABOL2",BHLCDA)=BHLCOM2
+95 SET INA("OBX14LABO",BHLCDA)=$GET(BHL("CDT"))
+96 SET INA("OBX3LABO",BHLCDA)=U_U_U_BHLCOM1_U_BHLCOM2
+97 SET INA("OBX5LABO",BHLCDA)=BHLCOM3
+98 SET INA("OBX3LABLC3",BHLCDA)=$GET(BHL("RLE"))
End DoDot:1
+99 DO ^INHF("HL IHS O01 OUT PARENT",.INDA,.INA)
+100 QUIT $$MSG(INHF)
+101 ;
MSG(BHLMVAR) ;-- return message defining status
+1 IF BHLMVAR="PAT"
SET BHLRMSG="Patient Not Passed In, Message Not Created"
+2 IF BHLMVAR="VST"
SET BHLRMSG="Visit Not Passed In, Message Not Created"
+3 IF BHLMVAR="VLAB"
SET BHLRMSG="VLAB Not Passed In, Message Not Created"
+4 IF BHLMVAR="MFL"
SET BHLRMSG="Mstr File Not Passed In, Message Not Created"
+5 IF BHLMVAR=0
SET BHLRMSG="Message Not Created, problem with GIS call"
+6 IF BHLMVAR
SET BHLRMSG=BHLMVAR_U_"Message Created Successfully"
+7 QUIT $GET(BHLRMSG)
+8 ;
