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
;
D
.;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
Q
;
; ----- 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."
Q
; ----- 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
Q
;
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
Q
;
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")
Q
;
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")
Q
LOOKBTN ;
I '$D(^BLRTXLOG("AOB",BLRACCN,BLRBTN)) S BLRPAR=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST,""),-1) D SET Q
D BLDMSTR
Q
;
LOOKANT ;
I '$D(^BLRTXLOG("AOA",BLRACCN,BLRBTN,BLRANTI)) D SET Q
D BLDMSTR
Q
;
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=""
Q
;
;
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=""
Q
;
GETIEN() ;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETIEN^BLRTNB")
S BLRERR=0 I BLRCMF="C" D GETNEW Q BLRENT
D
.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,"
Q
;
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
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
Q
;
;
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))
Q
;
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
Q
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
