Routine: BLRTNB

BLRTNB ; IHS/HQT/MJL - SET IHS LAB TRANSACTION LOG - BLOOD BANK ;MAY 06, 2009 9:58 AM

 ;;5.2T1;IHS LABORATORY;**1010,1018,1025,1026**;NOV 01, 1997

;;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER ^BLRTNB")

 ; S BLRLRDFN=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRDFN")),BLRIDT=$G(^("LRIDT")),BLRTEST=$G(^("BLRTEST")),BLRTESTN=$G(^("BLRTESTN")),BLRDR=$G(^("DR")),(BLRRES,BLRANTI,BLRBTN,BLRCMTS)="",BLR60F=0

 ; S BLRODT=$P(BLRIDS,","),BLRSEQ=$P(BLRIDS,",",2)

 ; S BLRACCN=$P($G(^LR(BLRLRDFN,"BB",BLRIDT,0)),U,6)

 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1026 Modifications

 ;       Quit if variables cannot be set

 S BLRLRDFN=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRDFN"))

 I $G(BLRLRDFN)=""  D NOTSETER("BLRLRDFN")  Q

 S BLRIDT=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRIDT"))

 I $G(BLRIDT)="" D NOTSETER("LRIDT")  Q

 S BLRTEST=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST"))

 I $G(BLRTEST)="" D NOTSETER("BLRTEST")  Q

 S BLRTESTN=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTESTN"))

 I $G(BLRTESTN)="" D NOTSETER("BLRTESTN")  Q

 S BLRDR=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"DR"))

 I $G(BLRDR)="" D NOTSETER("BLRDR")  Q

 S (BLRRES,BLRANTI,BLRBTN,BLRCMTS)=""

 S BLR60F=0

 S BLRODT=$P(BLRIDS,",")

 I $G(BLRODT)="" D NOTSETER("BLRODT")  Q

 S BLRSEQ=$P(BLRIDS,",",2)

 I $G(BLRSEQ)="" D NOTSETER("BLRSEQ")  Q

 S BLRACCN=$P($G(^LR(BLRLRDFN,"BB",BLRIDT,0)),U,6)

 I $G(BLRACCN)="" D NOTSETER("BLRACCN")  Q

 ; ----- END IHS/OIT/MKK LR*5.2*1026 Modifications

 .;I BLRDR["CMBS" D COOMBS Q

 .I $E(BLRDR,2,5)="LRBL" D COOMBS

 .D RHTYP

 I BLRBTN'="" S BLRRES="",BLR60F=1 D BLDMSTR

 D KILL

 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1026 Modifications

 ;       Set Error Flag & Error Array that will show up in BLRTXLOG.  Not Fatal.

NOTSETER(VAR) ; EP

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER NOTSETER^BLRTNB")

 S BLRERR=1

 S BLRERROR(1)="BLRTNB Error: "_VAR_" is Null/Zero."

 ; ----- END IHS/OIT/MKK LR*5.2*1026 Modifications

RHTYP ;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER RHTYP^BLRTNB")

 S BLRRES=$P($G(^LR(BLRLRDFN,"BB",BLRIDT,10)),U) I BLRRES'="" S BLRBTN="ABO INTERPRETATION" D LOOKBTN

 S BLRRES=$P($G(^LR(BLRLRDFN,"BB",BLRIDT,11)),U) I BLRRES'="" S BLRBTN="RH INTERPRETATION" D LOOKBTN

COOMBS ;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER COOMBS^BLRTNB")

 I $D(^LR(BLRLRDFN,"BB",BLRIDT,2)) D DIRECT

 I $D(^LR(BLRLRDFN,"BB",BLRIDT,6)) S BLRRES=$G(^(6)) D INDIR

DIRECT ;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER DIRECT^BLRTNB")

 S BLRRES=$P($G(^LR(BLRLRDFN,"BB",BLRIDT,2)),U,9)

 I BLRRES'="" S BLRBTN="DIRECT INTERPRETATION" D LOOKBTN

 Q:BLRRES'="P"

 Q:'$D(^LR(BLRLRDFN,"BB",BLRIDT,"EA"))

 S BLRPAR=$O(^BLRTXLOG("AOB",BLRACCN,BLRBTN,""),-1)

 S BLRANTI=0 F  S BLRANTI=$O(^LR(BLRLRDFN,"BB",BLRIDT,"EA",BLRANTI)) Q:BLRANTI=""  S BLRRES="POS" D LOOKANT

 K BLR("ANTIBODY")

INDIR ;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER INDIR^BLRTNB")

 S BLRBTN="INDIRECT INTERPRETATION" D LOOKBTN

 Q:BLRRES="N"

 Q:'$D(^LR(BLRLRDFN,"BB",BLRIDT,5))

 S BLRPAR=$O(^BLRTXLOG("AOB",BLRACCN,BLRBTN,""),-1)

 S BLRANTI=0 F  S BLRANTI=$O(^LR(BLRLRDFN,"BB",BLRIDT,5,BLRANTI)) Q:BLRANTI=""  S BLRRES="POS" D LOOKANT

 K BLR("ANTIBODY")

LOOKBTN ;

 I '$D(^BLRTXLOG("AOB",BLRACCN,BLRBTN)) S BLRPAR=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST,""),-1) D SET Q

 D BLDMSTR

LOOKANT ;

 I '$D(^BLRTXLOG("AOA",BLRACCN,BLRBTN,BLRANTI)) D SET Q

 D BLDMSTR

BLDMSTR ;

 S BLRCMF="M"

 I BLR60F S BLRCRSBS="""AAT"",BLRACCN,BLRTEST",BLRDIR=-1,BLROKCK="",BLRBADCK="",BLR("SEQUENCE NUMBER")=$$GETIEN Q:BLRERR

 I 'BLR60F D

 .S BLRCRSBS=""""_$S(BLRANTI'="":"AOA",1:"AOB")_""",BLRACCN,BLRBTN",BLRDIR=-1,BLROKCK="CHKDT",BLRBADCK=""

 .S:BLRANTI'="" BLRCRSBS=BLRCRSBS_",BLRANTI"

 .S BLR("SEQUENCE NUMBER")=$$GETIEN Q:BLRERR  S BLR("RESULT")=BLRRES,BLR("BB TEST NAME")=BLRBTN

 .S:BLRANTI'="" BLR("ANTIBODY")=BLRANTI S:BLRCMTS'="" BLR("COMMENTS")=BLRCMTS

 Q:BLRERR  D ^BLRNFLTL

 S BLRCMTS=""

SET ;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER SET^BLRTNB")

 S BLRCMF="C"

 S BLRCRSBS="""AOT"",BLRODTM,BLRSEQ,BLRTEST1",BLRDIR=1,BLROKCK="",BLRBADCK=""

 S BLRVAL=^LRO(69,BLRODT,1,BLRSEQ,0),BLRLRDFN=$P(BLRVAL,U,1),BLRODTM=$P(BLRVAL,U,5)

 S BLRDUZ=$P(BLRVAL,U,2),BLRDUZ2=DUZ(2)

 S BLRDTC=$P(BLRVAL,U,8),BLRLOCN=$P(BLRVAL,U,7)

 S BLRLOC="" I BLRLOCN'="" S BLRLOC=$O(^SC("B",BLRLOCN,"")) S:BLRLOC="" BLRLOC=$O(^SC("C",BLRLOCN,"")) I BLRLOC="" S X=BLRLOCN,DIC=44,DIC(0)="MX" D ^DIC S BLRLOC=+Y I Y=-1 S BLRLOC=""

 S BLRCLNC="" I BLRLOC'="" S BLRCLNC=$P($G(^SC(BLRLOC,0)),U,7)

 S BLRSPEC=$O(^LAB(61,"B","BLOOD",""))

 ;S BLRCAT="A" I $L($G(^DPT(BLRLRDFN,.1))) S BLRCAT="I"

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

  S BLRCAT="A" S X=$$GET1^DIQ(2,BLRLRDFN,.103) I X]"",X'["OBSERVATION" S BLRCAT="I"

  ;----- END IHS MODIFICATIONS MOD SUGGESTED BY LINDA FELS

 ; S BLRPROV=$P(BLRVAL,U,6) S:+BLRPROV>0 BLRPROVN=$P($G(^VA(200,$P(BLRVAL,U,6),0)),U) S:BLRPROVN="" BLRPROVN="Unknown Provider"

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1025

 S BLRPROV=$P(BLRVAL,U,6) S:+BLRPROV>0 BLRPROVN=$P($G(^VA(200,$P(BLRVAL,U,6),0)),U) S:$G(BLRPROVN)="" BLRPROVN="Unknown Provider"

 ;----- END IHS MODIFICATIONS LR*5.2*1025

 S BLRDFN=$P($G(^LR(BLRLRDFN,0)),U,3),BLRFILE=$P($G(^LR(BLRLRDFN,0)),U,2),BLRODTM=$G(BLRODTM)

 S BLR("LAB MODULE")="BB"

 S BLR("LRFILE")=BLRFILE,BLR("LRDFN")=BLRLRDFN,BLR("PATIENT POINTER VALUE")=BLRDFN,BLR("ORDERING PROVIDER POINTER")=BLRPROV,BLR("VERIFIER POINTER")=BLRDUZ

 S BLR("ORDER DATE")=$P(BLRVAL,U,5),BLR("ORDER SEQUENCE NUMBER")=BLRSEQ,BLR("ORDER NUMBER")=$G(^LRO(69,BLRODT,1,BLRSEQ,.1))

 D NOW^%DTC S BLR("ENTRY DATE/TIME")=%

 S BLR("COLLECTION DATE/TIME")=BLRDTC,BLR("CLINIC STOP CODE POINTER")=BLRCLNC

 S BLR("ORDERING LOCATION POINTER")=BLRLOC,BLR("DUZ(2)")=BLRDUZ2,BLR("I/O CATEGORY")=BLRCAT,BLR("ACCESSION NUMBER")=BLRACCN,BLR("SITE/SPECIMEN POINTER")=BLRSPEC

 S BLRTEST1=BLRTEST D CPTCODE^BLRTN

 S BLR("PARENT POINTER")=BLRPAR,BLR("CPT LAB CODE POINTER")=BLRCPTP,BLR("CPT CODE")=BLRCPTS,BLR("RESULT")=BLRRES,BLR("BB TEST NAME")=BLRBTN,BLR("PANEL/TEST POINTER")=BLRTEST

 I BLRANTI'="" S BLR("ANTIBODY")=BLRANTI

 S BLR("SEQUENCE NUMBER")=$$GETIEN Q:BLRERR

 D ^BLRNFLTL

 S BLRCMTS=""

GETIEN() ;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETIEN^BLRTNB")

 S BLRERR=0 I BLRCMF="C" D GETNEW Q BLRENT

 .S BLRCRGL="^BLRTXLOG("_BLRCRSBS_")",BLRENT=$O(@BLRCRGL@(""),BLRDIR)

 .S:'BLRENT BLRERR=1

 .I BLRENT,BLROKCK'="" D @BLROKCK

 .I 'BLRERR,BLRBADCK'="" D @BLRBADCK

 .I BLRERR D EMSG Q

 .S BLRIEN=BLRENT_"," Q

 Q BLRENT

GETNEW ;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETNEW^BLRTNB")

 S BLRENT=$G(^BLRTXLOG("SEQ"))

 I 'BLRENT S BLRENT=$O(^BLRTXLOG("@"),-1) I BLRENT,'$D(^BLRTXLOG(1)) S BLRENT=0

 F BLRENT=BLRENT+1:1 Q:'$D(^BLRTXLOG(BLRENT))

 S BLRENTS="BLRENTS",BLRENTS(1)=BLRENT,^BLRTXLOG("SEQ")=BLRENT,BLRIEN="+1,"

CHKDT ;

 S BLRCDT=$P($G(^BLRTXLOG(BLRENT,12)),U)

 Q:$E(BLRCDT,1,3)=$E(DT,1,3)

 I ($E(BLRCDT,1,3)+1)'=$E(DT,1,3) S BLRERR=1,BLRDTER=1 Q  ;MORE THAN 1 YEAR AHEAD

 I $E(BLRCDT,4,5)<11 S BLRERR=1,BLRDTER=1 Q

EMSG ;

 ; Log an error because the crossreference isn't set.

 I 'BLRENT D

 .S BLRERR=1,BLRERROR(1)="Something wrong -- problem with IHS Lab Transaction Log Cross Reference: "_BLRCRGL

GETCPT ;

 S BLRFOUND=1

 S BLRCPTP=BLRXII

 S (BLRCPTS,BLRCPTC)="" F  S BLRCPTC=$O(^BLRCPT(BLRXII,11,"B",BLRCPTC)) Q:BLRCPTC=""  S BLRCPTS=BLRCPTS_BLRCPTC_";"

 I $L(BLRCPTS,";")=2 S BLRCPTS=$P(BLRCPTS,";",1)

 I $E(BLRCPTS,$L(BLRCPTS))=";" S BLRCPTS=$E(BLRCPTS,$L(BLRCPTS))

KILL ;

 K BLR60F,BLRANTI,BLRBTN,BLRCAT,BLRCLNC,BLRCMTS,BLRCPTC,BLRCPTF,BLRCPTP,BLRCPTS,BLRCST,BLRLRDFN,BLRDTC,BLRDUZ,BLRDUZ2,BLRDUZN,BLRENT,BLRFID,BLRFILE,BLRFOUND

 K BLRIDT,BLRLOC,BLRLOCN,BLRLOGDA,BLRLRDFN,BLRODT,BLRODTM,BLRPAR,BLRPROV,BLRPROVN,BLRRES,BLRSEQ,BLRSPEC,BLRSTR,BLRSTR1,BLRTEST

 K BLRTESTN,BLRVAL,BLRXII

BLRTNB    ; IHS/HQT/MJL - SET IHS LAB TRANSACTION LOG - BLOOD BANK ;MAY 06, 2009 9:58 AM

 +1       ;;5.2T1;IHS LABORATORY;**1010,1018,1025,1026**;NOV 01, 1997

 +2       ;;

 +3        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER ^BLRTNB")

 +4       ; S BLRLRDFN=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRDFN")),BLRIDT=$G(^("LRIDT")),BLRTEST=$G(^("BLRTEST")),BLRTESTN=$G(^("BLRTESTN")),BLRDR=$G(^("DR")),(BLRRES,BLRANTI,BLRBTN,BLRCMTS)="",BLR60F=0

 +5       ; S BLRODT=$P(BLRIDS,","),BLRSEQ=$P(BLRIDS,",",2)

 +6       ; S BLRACCN=$P($G(^LR(BLRLRDFN,"BB",BLRIDT,0)),U,6)

 +7       ; ----- BEGIN IHS/OIT/MKK LR*5.2*1026 Modifications

 +8       ;       Quit if variables cannot be set

 +9        SET BLRLRDFN=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRDFN"))

 +10       IF $GET(BLRLRDFN)=""

               DO NOTSETER("BLRLRDFN")

               QUIT

 +11      ;

 +12       SET BLRIDT=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRIDT"))

 +13       IF $GET(BLRIDT)=""

               DO NOTSETER("LRIDT")

               QUIT

 +14      ;

 +15       SET BLRTEST=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST"))

 +16       IF $GET(BLRTEST)=""

               DO NOTSETER("BLRTEST")

               QUIT

 +17      ;

 +18       SET BLRTESTN=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTESTN"))

 +19       IF $GET(BLRTESTN)=""

               DO NOTSETER("BLRTESTN")

               QUIT

 +20      ;

 +21       SET BLRDR=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"DR"))

 +22       IF $GET(BLRDR)=""

               DO NOTSETER("BLRDR")

               QUIT

 +23      ;

 +24       SET (BLRRES,BLRANTI,BLRBTN,BLRCMTS)=""

 +25       SET BLR60F=0

 +26      ;

 +27       SET BLRODT=$PIECE(BLRIDS,",")

 +28       IF $GET(BLRODT)=""

               DO NOTSETER("BLRODT")

               QUIT

 +29      ;

 +30       SET BLRSEQ=$PIECE(BLRIDS,",",2)

 +31       IF $GET(BLRSEQ)=""

               DO NOTSETER("BLRSEQ")

               QUIT

 +32      ;

 +33       SET BLRACCN=$PIECE($GET(^LR(BLRLRDFN,"BB",BLRIDT,0)),U,6)

 +34       IF $GET(BLRACCN)=""

               DO NOTSETER("BLRACCN")

               QUIT

 +35      ;

 +36      ; ----- END IHS/OIT/MKK LR*5.2*1026 Modifications

 +37      ;

 +38       Begin DoDot:1

 +39      ;I BLRDR["CMBS" D COOMBS Q

 +40           IF $EXTRACT(BLRDR,2,5)="LRBL"

                   DO COOMBS

 +41           DO RHTYP

           End DoDot:1

 +42       IF BLRBTN'=""

               SET BLRRES=""

               SET BLR60F=1

               DO BLDMSTR

 +43       DO KILL

 +44       QUIT

 +45      ;

 +46      ; ----- BEGIN IHS/OIT/MKK LR*5.2*1026 Modifications

 +47      ;       Set Error Flag & Error Array that will show up in BLRTXLOG.  Not Fatal.

NOTSETER(VAR) ; EP

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER NOTSETER^BLRTNB")

 +2        SET BLRERR=1

 +3        SET BLRERROR(1)="BLRTNB Error: "_VAR_" is Null/Zero."

 +4        QUIT

 +5       ; ----- END IHS/OIT/MKK LR*5.2*1026 Modifications

 +6       ;

RHTYP     ;

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER RHTYP^BLRTNB")

 +2        SET BLRRES=$PIECE($GET(^LR(BLRLRDFN,"BB",BLRIDT,10)),U)

           IF BLRRES'=""

               SET BLRBTN="ABO INTERPRETATION"

               DO LOOKBTN

 +3        SET BLRRES=$PIECE($GET(^LR(BLRLRDFN,"BB",BLRIDT,11)),U)

           IF BLRRES'=""

               SET BLRBTN="RH INTERPRETATION"

               DO LOOKBTN

 +4        QUIT

 +5       ;

COOMBS    ;

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER COOMBS^BLRTNB")

 +2        IF $DATA(^LR(BLRLRDFN,"BB",BLRIDT,2))

               DO DIRECT

 +3        IF $DATA(^LR(BLRLRDFN,"BB",BLRIDT,6))

               SET BLRRES=$GET(^(6))

               DO INDIR

 +4        QUIT

 +5       ;

DIRECT    ;

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER DIRECT^BLRTNB")

 +2        SET BLRRES=$PIECE($GET(^LR(BLRLRDFN,"BB",BLRIDT,2)),U,9)

 +3        IF BLRRES'=""

               SET BLRBTN="DIRECT INTERPRETATION"

               DO LOOKBTN

 +4        IF BLRRES'="P"

               QUIT

 +5        IF '$DATA(^LR(BLRLRDFN,"BB",BLRIDT,"EA"))

               QUIT

 +6        SET BLRPAR=$ORDER(^BLRTXLOG("AOB",BLRACCN,BLRBTN,""),-1)

 +7        SET BLRANTI=0

FOR

               SET BLRANTI=$ORDER(^LR(BLRLRDFN,"BB",BLRIDT,"EA",BLRANTI))

               IF BLRANTI=""

                   QUIT

               SET BLRRES="POS"

               DO LOOKANT

 +8        KILL BLR("ANTIBODY")

 +9        QUIT

 +10      ;

INDIR     ;

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER INDIR^BLRTNB")

 +2        SET BLRBTN="INDIRECT INTERPRETATION"

           DO LOOKBTN

 +3        IF BLRRES="N"

               QUIT

 +4        IF '$DATA(^LR(BLRLRDFN,"BB",BLRIDT,5))

               QUIT

 +5        SET BLRPAR=$ORDER(^BLRTXLOG("AOB",BLRACCN,BLRBTN,""),-1)

 +6        SET BLRANTI=0

FOR

               SET BLRANTI=$ORDER(^LR(BLRLRDFN,"BB",BLRIDT,5,BLRANTI))

               IF BLRANTI=""

                   QUIT

               SET BLRRES="POS"

               DO LOOKANT

 +7        KILL BLR("ANTIBODY")

 +8        QUIT

LOOKBTN   ;

 +1        IF '$DATA(^BLRTXLOG("AOB",BLRACCN,BLRBTN))

               SET BLRPAR=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST,""),-1)

               DO SET

               QUIT

 +2        DO BLDMSTR

 +3        QUIT

 +4       ;

LOOKANT   ;

 +1        IF '$DATA(^BLRTXLOG("AOA",BLRACCN,BLRBTN,BLRANTI))

               DO SET

               QUIT

 +2        DO BLDMSTR

 +3        QUIT

 +4       ;

BLDMSTR   ;

 +1        SET BLRCMF="M"

 +2        IF BLR60F

               SET BLRCRSBS="""AAT"",BLRACCN,BLRTEST"

               SET BLRDIR=-1

               SET BLROKCK=""

               SET BLRBADCK=""

               SET BLR("SEQUENCE NUMBER")=$$GETIEN

               IF BLRERR

                   QUIT

 +3        IF 'BLR60F

               Begin DoDot:1

 +4                SET BLRCRSBS=""""_$SELECT(BLRANTI'="":"AOA",1:"AOB")_""",BLRACCN,BLRBTN"

                   SET BLRDIR=-1

                   SET BLROKCK="CHKDT"

                   SET BLRBADCK=""

 +5                IF BLRANTI'=""

                       SET BLRCRSBS=BLRCRSBS_",BLRANTI"

 +6                SET BLR("SEQUENCE NUMBER")=$$GETIEN

                   IF BLRERR

                       QUIT

                   SET BLR("RESULT")=BLRRES

                   SET BLR("BB TEST NAME")=BLRBTN

 +7                IF BLRANTI'=""

                       SET BLR("ANTIBODY")=BLRANTI

                   IF BLRCMTS'=""

                       SET BLR("COMMENTS")=BLRCMTS

               End DoDot:1

 +8        IF BLRERR

               QUIT

           DO ^BLRNFLTL

 +9        SET BLRCMTS=""

 +10       QUIT

 +11      ;

 +12      ;

SET       ;

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER SET^BLRTNB")

 +2        SET BLRCMF="C"

 +3        SET BLRCRSBS="""AOT"",BLRODTM,BLRSEQ,BLRTEST1"

           SET BLRDIR=1

           SET BLROKCK=""

           SET BLRBADCK=""

 +4        SET BLRVAL=^LRO(69,BLRODT,1,BLRSEQ,0)

           SET BLRLRDFN=$PIECE(BLRVAL,U,1)

           SET BLRODTM=$PIECE(BLRVAL,U,5)

 +5        SET BLRDUZ=$PIECE(BLRVAL,U,2)

           SET BLRDUZ2=DUZ(2)

 +6        SET BLRDTC=$PIECE(BLRVAL,U,8)

           SET BLRLOCN=$PIECE(BLRVAL,U,7)

 +7        SET BLRLOC=""

           IF BLRLOCN'=""

               SET BLRLOC=$ORDER(^SC("B",BLRLOCN,""))

               IF BLRLOC=""

                   SET BLRLOC=$ORDER(^SC("C",BLRLOCN,""))

               IF BLRLOC=""

                   SET X=BLRLOCN

                   SET DIC=44

                   SET DIC(0)="MX"

                   DO ^DIC

                   SET BLRLOC=+Y

                   IF Y=-1

                       SET BLRLOC=""

 +8        SET BLRCLNC=""

           IF BLRLOC'=""

               SET BLRCLNC=$PIECE($GET(^SC(BLRLOC,0)),U,7)

 +9        SET BLRSPEC=$ORDER(^LAB(61,"B","BLOOD",""))

 +10      ;S BLRCAT="A" I $L($G(^DPT(BLRLRDFN,.1))) S BLRCAT="I"

 +11      ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +12       SET BLRCAT="A"

           SET X=$$GET1^DIQ(2,BLRLRDFN,.103)

           IF X]""

               IF X'["OBSERVATION"

                   SET BLRCAT="I"

 +13      ;----- END IHS MODIFICATIONS MOD SUGGESTED BY LINDA FELS

 +14      ; S BLRPROV=$P(BLRVAL,U,6) S:+BLRPROV>0 BLRPROVN=$P($G(^VA(200,$P(BLRVAL,U,6),0)),U) S:BLRPROVN="" BLRPROVN="Unknown Provider"

 +15      ;----- BEGIN IHS MODIFICATIONS LR*5.2*1025

 +16       SET BLRPROV=$PIECE(BLRVAL,U,6)

           IF +BLRPROV>0

               SET BLRPROVN=$PIECE($GET(^VA(200,$PIECE(BLRVAL,U,6),0)),U)

           IF $GET(BLRPROVN)=""

               SET BLRPROVN="Unknown Provider"

 +17      ;----- END IHS MODIFICATIONS LR*5.2*1025

 +18       SET BLRDFN=$PIECE($GET(^LR(BLRLRDFN,0)),U,3)

           SET BLRFILE=$PIECE($GET(^LR(BLRLRDFN,0)),U,2)

           SET BLRODTM=$GET(BLRODTM)

 +19       SET BLR("LAB MODULE")="BB"

 +20       SET BLR("LRFILE")=BLRFILE

           SET BLR("LRDFN")=BLRLRDFN

           SET BLR("PATIENT POINTER VALUE")=BLRDFN

           SET BLR("ORDERING PROVIDER POINTER")=BLRPROV

           SET BLR("VERIFIER POINTER")=BLRDUZ

 +21       SET BLR("ORDER DATE")=$PIECE(BLRVAL,U,5)

           SET BLR("ORDER SEQUENCE NUMBER")=BLRSEQ

           SET BLR("ORDER NUMBER")=$GET(^LRO(69,BLRODT,1,BLRSEQ,.1))

 +22       DO NOW^%DTC

           SET BLR("ENTRY DATE/TIME")=%

 +23       SET BLR("COLLECTION DATE/TIME")=BLRDTC

           SET BLR("CLINIC STOP CODE POINTER")=BLRCLNC

 +24       SET BLR("ORDERING LOCATION POINTER")=BLRLOC

           SET BLR("DUZ(2)")=BLRDUZ2

           SET BLR("I/O CATEGORY")=BLRCAT

           SET BLR("ACCESSION NUMBER")=BLRACCN

           SET BLR("SITE/SPECIMEN POINTER")=BLRSPEC

 +25       SET BLRTEST1=BLRTEST

           DO CPTCODE^BLRTN

 +26       SET BLR("PARENT POINTER")=BLRPAR

           SET BLR("CPT LAB CODE POINTER")=BLRCPTP

           SET BLR("CPT CODE")=BLRCPTS

           SET BLR("RESULT")=BLRRES

           SET BLR("BB TEST NAME")=BLRBTN

           SET BLR("PANEL/TEST POINTER")=BLRTEST

 +27       IF BLRANTI'=""

               SET BLR("ANTIBODY")=BLRANTI

 +28       SET BLR("SEQUENCE NUMBER")=$$GETIEN

           IF BLRERR

               QUIT

 +29       DO ^BLRNFLTL

 +30       SET BLRCMTS=""

 +31       QUIT

 +32      ;

GETIEN()  ;

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER GETIEN^BLRTNB")

 +2        SET BLRERR=0

           IF BLRCMF="C"

               DO GETNEW

               QUIT BLRENT

 +3        Begin DoDot:1

 +4            SET BLRCRGL="^BLRTXLOG("_BLRCRSBS_")"

               SET BLRENT=$ORDER(@BLRCRGL@(""),BLRDIR)

 +5            IF 'BLRENT

                   SET BLRERR=1

 +6            IF BLRENT

                   IF BLROKCK'=""

                       DO @BLROKCK

 +7            IF 'BLRERR

                   IF BLRBADCK'=""

                       DO @BLRBADCK

 +8            IF BLRERR

                   DO EMSG

                   QUIT

 +9            SET BLRIEN=BLRENT_","

               QUIT

           End DoDot:1

 +10       QUIT BLRENT

 +11      ;

GETNEW    ;

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER GETNEW^BLRTNB")

 +2        SET BLRENT=$GET(^BLRTXLOG("SEQ"))

 +3        IF 'BLRENT

               SET BLRENT=$ORDER(^BLRTXLOG("@"),-1)

               IF BLRENT

                   IF '$DATA(^BLRTXLOG(1))

                       SET BLRENT=0

 +4        FOR BLRENT=BLRENT+1:1

               IF '$DATA(^BLRTXLOG(BLRENT))

                   QUIT

 +5        SET BLRENTS="BLRENTS"

           SET BLRENTS(1)=BLRENT

           SET ^BLRTXLOG("SEQ")=BLRENT

           SET BLRIEN="+1,"

 +6        QUIT

 +7       ;

CHKDT     ;

 +1        SET BLRCDT=$PIECE($GET(^BLRTXLOG(BLRENT,12)),U)

 +2        IF $EXTRACT(BLRCDT,1,3)=$EXTRACT(DT,1,3)

               QUIT

 +3       ;MORE THAN 1 YEAR AHEAD

           IF ($EXTRACT(BLRCDT,1,3)+1)'=$EXTRACT(DT,1,3)

               SET BLRERR=1

               SET BLRDTER=1

               QUIT

 +4        IF $EXTRACT(BLRCDT,4,5)<11

               SET BLRERR=1

               SET BLRDTER=1

               QUIT

 +5        QUIT

 +6       ;

EMSG      ;

 +1       ; Log an error because the crossreference isn't set.

 +2        IF 'BLRENT

               Begin DoDot:1

 +3                SET BLRERR=1

                   SET BLRERROR(1)="Something wrong -- problem with IHS Lab Transaction Log Cross Reference: "_BLRCRGL

               End DoDot:1

 +4        QUIT

 +5       ;

 +6       ;

GETCPT    ;

 +1        SET BLRFOUND=1

 +2        SET BLRCPTP=BLRXII

 +3        SET (BLRCPTS,BLRCPTC)=""

FOR

               SET BLRCPTC=$ORDER(^BLRCPT(BLRXII,11,"B",BLRCPTC))

               IF BLRCPTC=""

                   QUIT

               SET BLRCPTS=BLRCPTS_BLRCPTC_";"

 +4        IF $LENGTH(BLRCPTS,";")=2

               SET BLRCPTS=$PIECE(BLRCPTS,";",1)

 +5        IF $EXTRACT(BLRCPTS,$LENGTH(BLRCPTS))=";"

               SET BLRCPTS=$EXTRACT(BLRCPTS,$LENGTH(BLRCPTS))

 +6        QUIT

 +7       ;

KILL      ;

 +1        KILL BLR60F,BLRANTI,BLRBTN,BLRCAT,BLRCLNC,BLRCMTS,BLRCPTC,BLRCPTF,BLRCPTP,BLRCPTS,BLRCST,BLRLRDFN,BLRDTC,BLRDUZ,BLRDUZ2,BLRDUZN,BLRENT,BLRFID,BLRFILE,BLRFOUND

 +2        KILL BLRIDT,BLRLOC,BLRLOCN,BLRLOGDA,BLRLRDFN,BLRODT,BLRODTM,BLRPAR,BLRPROV,BLRPROVN,BLRRES,BLRSEQ,BLRSPEC,BLRSTR,BLRSTR1,BLRTEST

 +3        KILL BLRTESTN,BLRVAL,BLRXII

 +4        QUIT

BLRTNB.m