BHLRLAB.m

BHLRLAB ;cmi/flag/maw - BHL Setup Ref Lab Segments 

 ;;3.01;BHL IHS Interfaces with GIS;**4**;OCT 15, 2002

 ;

 ;

 ;this routine will setup special formatting for data residing in the

 ;PV1, OBR, and OBX segments

 ;

ORM ;EP - this is the main routine driver

 D MORC,MOBR

 Q

 ;

ORU ;EP - this is the main routine driver

 D PV1,OBR,OBX

 Q

 ;

PV1 ;-- setup PV1 data

 S INA("PV13LAB",1)=$$PLOC(BHL("VIEN"))

 S INA("PV110LAB",1)=$$CLNC(BHL("VIEN"))

 Q

 ;

OBR ;-- setup OBR data

 S BHL("VLAB")=$G(INDA(9000010.09,1))

 S INA("OBR4LAB",1)=$$LOINC(BHL("VLAB"))

 S INA("OBR16LAB",1)=CS_$$GET1^DIQ(9000010.09,BHL("VLAB"),1202,"E")

 Q

 ;

OBX ;-- setup OBX data

 S INA("OBX7LAB",1)=$$REFLH(BHL("VLAB"))

 S INA("OBX8LAB",1)=$P($G(^AUPNVLAB(BHL("VLAB"),0)),U,5)

 Q

 ;

MORC ;-- setup ORM ORC segment

 S INA("ORC2LABO")=""

 S INA("ORC12LABO")=""

 Q

 ;

MOBR ;-- setup ORM ORC segment

 S INA("OBR4LABO")=""

 S INA("OBR7LABO")=""

 S INA("OBR22LABO")=""

 S INA("OBR27LABO")=""

 Q

 ;

PLOC(BHLZX)        ;-- get patient location

 S BHL("LOCI")=$P($G(^AUPNVSIT(BHLZX,0)),U,6)

 I BHL("LOCI")="" Q ""

 S BHL("ASUFAC")=$P($G(^AUTTLOC(BHL("LOCI"),0)),U,10)

 S BHL("LOCE")=$$VAL^XBDIQ1(9000010,BHLZX,.06)

 Q BHL("ASUFAC")_CS_BHL("LOCE")_CS_"99IHS"

 ;

CLNC(BHLZX)        ;-- get patient clinic code

 S BHL("CLNI")=$P($G(^AUPNVSIT(BHLZX,0)),U,8)

 I BHL("CLNI")="" Q ""

 S BHL("CLNC")=$P($G(^DIC(40.7,BHL("CLNI"),0)),U,2)

 Q BHL("CLNC")

 ;

LOINC(BHLZV)       ;-- get loinc setup

 S BHL("LABTI")=$P($G(^AUPNVLAB(BHLZV,0)),U)

 S BHL("LABTE")=$P($G(^LAB(60,BHL("LABTI"),0)),U)

 S BHL("LOINC")=$P($G(^AUPNVLAB(BHLZV,11)),U,13)

 I BHL("LOINC")="" Q ""

 S BHLCHK=$P($G(^LAB(95.3,BHL("LOINC"),9999999)),U,2)

 ;Q BHL("LOINC")_CS_BHL("LABTE")_CS_"L"

 Q BHLCHK_CS_BHL("LABTE")_CS_"LN"  ;maw chk digit

 ;

REFLH(BHLZV)       ;-- set up ref low/high

 S BHL("REFL")=$P($G(^AUPNVLAB(BHLZV,11)),U,4)

 S BHL("REFH")=$P($G(^AUPNVLAB(BHLZV,11)),U,5)

 Q BHL("REFL")_" - "_BHL("REFH")

 ;

BHLRLAB   ;cmi/flag/maw - BHL Setup Ref Lab Segments 

 +1       ;;3.01;BHL IHS Interfaces with GIS;**4**;OCT 15, 2002

 +2       ;

 +3       ;

 +4       ;this routine will setup special formatting for data residing in the

 +5       ;PV1, OBR, and OBX segments

 +6       ;

ORM       ;EP - this is the main routine driver

 +1        DO MORC

           DO MOBR

 +2        QUIT 

 +3       ;

ORU       ;EP - this is the main routine driver

 +1        DO PV1

           DO OBR

           DO OBX

 +2        QUIT 

 +3       ;

PV1       ;-- setup PV1 data

 +1        SET INA("PV13LAB",1)=$$PLOC(BHL("VIEN"))

 +2        SET INA("PV110LAB",1)=$$CLNC(BHL("VIEN"))

 +3        QUIT 

 +4       ;

OBR       ;-- setup OBR data

 +1        SET BHL("VLAB")=$GET(INDA(9000010.09,1))

 +2        SET INA("OBR4LAB",1)=$$LOINC(BHL("VLAB"))

 +3        SET INA("OBR16LAB",1)=CS_$$GET1^DIQ(9000010.09,BHL("VLAB"),1202,"E")

 +4        QUIT 

 +5       ;

OBX       ;-- setup OBX data

 +1        SET INA("OBX7LAB",1)=$$REFLH(BHL("VLAB"))

 +2        SET INA("OBX8LAB",1)=$PIECE($GET(^AUPNVLAB(BHL("VLAB"),0)),U,5)

 +3        QUIT 

 +4       ;

MORC      ;-- setup ORM ORC segment

 +1        SET INA("ORC2LABO")=""

 +2        SET INA("ORC12LABO")=""

 +3        QUIT 

 +4       ;

MOBR      ;-- setup ORM ORC segment

 +1        SET INA("OBR4LABO")=""

 +2        SET INA("OBR7LABO")=""

 +3        SET INA("OBR22LABO")=""

 +4        SET INA("OBR27LABO")=""

 +5        QUIT 

 +6       ;

PLOC(BHLZX) ;-- get patient location

 +1        SET BHL("LOCI")=$PIECE($GET(^AUPNVSIT(BHLZX,0)),U,6)

 +2        IF BHL("LOCI")=""

               QUIT ""

 +3        SET BHL("ASUFAC")=$PIECE($GET(^AUTTLOC(BHL("LOCI"),0)),U,10)

 +4        SET BHL("LOCE")=$$VAL^XBDIQ1(9000010,BHLZX,.06)

 +5        QUIT BHL("ASUFAC")_CS_BHL("LOCE")_CS_"99IHS"

 +6       ;

CLNC(BHLZX) ;-- get patient clinic code

 +1        SET BHL("CLNI")=$PIECE($GET(^AUPNVSIT(BHLZX,0)),U,8)

 +2        IF BHL("CLNI")=""

               QUIT ""

 +3        SET BHL("CLNC")=$PIECE($GET(^DIC(40.7,BHL("CLNI"),0)),U,2)

 +4        QUIT BHL("CLNC")

 +5       ;

LOINC(BHLZV) ;-- get loinc setup

 +1        SET BHL("LABTI")=$PIECE($GET(^AUPNVLAB(BHLZV,0)),U)

 +2        SET BHL("LABTE")=$PIECE($GET(^LAB(60,BHL("LABTI"),0)),U)

 +3        SET BHL("LOINC")=$PIECE($GET(^AUPNVLAB(BHLZV,11)),U,13)

 +4        IF BHL("LOINC")=""

               QUIT ""

 +5        SET BHLCHK=$PIECE($GET(^LAB(95.3,BHL("LOINC"),9999999)),U,2)

 +6       ;Q BHL("LOINC")_CS_BHL("LABTE")_CS_"L"

 +7       ;maw chk digit

           QUIT BHLCHK_CS_BHL("LABTE")_CS_"LN"

 +8       ;

REFLH(BHLZV) ;-- set up ref low/high

 +1        SET BHL("REFL")=$PIECE($GET(^AUPNVLAB(BHLZV,11)),U,4)

 +2        SET BHL("REFH")=$PIECE($GET(^AUPNVLAB(BHLZV,11)),U,5)

 +3        QUIT BHL("REFL")_" - "_BHL("REFH")

 +4       ;