Routine: BLRBLTL

BLRBLTL ; IHS/DIR/FJE - SET IHS LAB TRANSACTION LOG - BLOOD BANK ;

 ;;5.2T9;LR;**1018**;Nov 17, 2004

;;

 S BLRIDT=LRI,BLRTEST=LRT,BLRTESTN=$P(LRT(BLRTEST),U,1),(BLRRES,BLRANTI,BLRBTN,BLRCMTS)="",BLR60F=0

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

 .I DR["CMBS" D COOMBS Q

 .D RHTYP

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

 D KILL

RHTYP ;

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

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

COOMBS ;

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

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

DIRECT ;

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

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

 Q:BLRRES'="P"

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

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

 S BLRPAR=$O(^BLRTXLOG("AOB",BLRACCN,BLRBTN,""),-1)  ;IHS/DIR TUC/AAB 05/07/98

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

INDIR ;

 S BLRBTN="INDIRECT INTERPRETATION" D LOOKBTN

 Q:BLRRES="N"

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

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

 S BLRPAR=$O(^BLRTXLOG("AOB",BLRACCN,BLRBTN,""),-1)  ;IHS/DIR TUC/AAB 05/07/98

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

LOOKBTN ;

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

 I '$D(^BLRTXLOG("AOB",BLRACCN,BLRBTN)) S BLRPAR=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST,""),-1) D SET Q  ;IHS/DIR TUC/AAB 05/07/98

 D BLDMSTR

LOOKANT ;

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

 D BLDMSTR

BLDMSTR ;

 S:BLR60F BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRACCN,BLRTEST)~STATUS FLAG_BLRPHASE"

 I 'BLR60F D

 .S BLRSTR="SEQUENCE NUMBER_$$GETBIEN(BLRACCN,BLRBTN"_$S(BLRANTI="":")",1:",BLRANTI)~ANTIBODY_BLRANTI")_"~STATUS FLAG_BLRPHASE~RESULT_BLRRES~BB TEST NAME_BLRBTN"

 .S:BLRCMTS'="" BLRSTR=BLRSTR_"~COMMENTS_BLRCMTS"

 D ^BLRFLTL("M",BLRSTR)

 S BLRCMTS=""

SET ;

 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 BLRDUZN=$S($D(^VA(200,BLRDUZ,0)):$P(^(0),U,1),1:"UNK"_BLRDUZ)

 S BLRDTC=$P($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(^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 MODIFICATINS 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 SENT IN BY LINDA FELS

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

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

 S BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRODTM,BLRSEQ,BLRTEST)~STATUS FLAG_BLRPHASE~LAB MODULE_""BB""~"

 S BLRSTR=BLRSTR_"LRFILE_BLRFILE~LRDFN_BLRLRDFN~PATIENT POINTER VALUE_BLRDFN~ORDERING PROVIDER POINTER_BLRPROV~VERIFIER POINTER_BLRDUZ~"

 S BLRSTR=BLRSTR_"ORDER DATE_$P(BLRVAL,U,5)~ORDER SEQ. NUMBER_BLRSEQ~ORDERING PROVIDER NAME_BLRPROVN~ORDER NUMBER_^LRO(69,BLRODT,1,BLRSEQ,.1)~"

 S BLRSTR=BLRSTR_"COLLECTION DATE/TIME_BLRDTC~VERIFIER NAME_BLRDUZN~ORDERING LOCATION NAME_BLRLOCN~ENTRY DATE/TIME_BLR(""ORDER DATE"")~CLINIC STOP CODE POINTER_BLRCLNC~"

 S BLRSTR=BLRSTR_"ORDERING LOCATION POINTER_BLRLOC~DUZ(2)_BLRDUZ2~I/O CATEGORY_BLRCAT~ACCESSION NUMBER_BLRACCN~SITE/SPECIMEN POINTER_BLRSPEC~"

 ;S (BLRXII,BLRCPTS,BLRCPTP)="" F  S BLRFOUND=0,BLRXII=$O(^BLRCPT("C",BLRTEST,BLRXII)) Q:(BLRXII=""!(BLRFOUND))  S BLRCPTF=$P(^BLRCPT(BLRXII,1),U,2) Q:BLRCPTF  D GETCPT Q

 S BLRTEST1=BLRTEST D CPTCODE^BLRSLTL1

 S BLRSTR1="PARENT POINTER_BLRPAR~CPT LAB CODE POINTER_BLRCPTP~CPT CODE_BLRCPTS~RESULT_BLRRES~BB TEST NAME_BLRBTN~PANEL/TEST POINTER_BLRTEST"

 I BLRANTI'="" S BLRSTR1=BLRSTR1_"~ANTIBODY_BLRANTI"

 D ^BLRFLTL("C",BLRSTR_BLRSTR1)

 S BLRCMTS=""

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,BLRACCN,BLRANTI,BLRBTN,BLRCAT,BLRCLNC,BLRCMTS,BLRCPTC,BLRCPTF,BLRCPTP,BLRCPTS,BLRCST,BLRDFN,BLRDTC,BLRDUZ,BLRDUZ2,BLRDUZN,BLRENT,BLRFID,BLRFILE,BLRFOUND

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

 K BLRTESTN,BLRVAL,BLRXII

BLRBLTL   ; IHS/DIR/FJE - SET IHS LAB TRANSACTION LOG - BLOOD BANK ;

 +1       ;;5.2T9;LR;**1018**;Nov 17, 2004

 +2       ;;

 +3        SET BLRIDT=LRI

           SET BLRTEST=LRT

           SET BLRTESTN=$PIECE(LRT(BLRTEST),U,1)

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

           SET BLR60F=0

 +4        SET BLRACCN=$PIECE(^LR(LRDFN,"BB",BLRIDT,0),U,6)

 +5        Begin DoDot:1

 +6            IF DR["CMBS"

                   DO COOMBS

                   QUIT

 +7            DO RHTYP

           End DoDot:1

 +8        IF BLRBTN'=""

               SET BLRRES=""

               SET BLR60F=1

               DO BLDMSTR

 +9        DO KILL

 +10       QUIT

 +11      ;

RHTYP     ;

 +1        SET BLRRES=$PIECE(^LR(LRDFN,"BB",BLRIDT,10),U,1)

           IF BLRRES'=""

               SET BLRBTN="ABO INTERPRETATION"

               DO LOOKBTN

 +2        SET BLRRES=$PIECE(^LR(LRDFN,"BB",BLRIDT,11),U,1)

           IF BLRRES'=""

               SET BLRBTN="RH INTERPRETATION"

               DO LOOKBTN

 +3        QUIT

 +4       ;

COOMBS    ;

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

               DO DIRECT

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

               SET BLRRES=^(6)

               DO INDIR

 +3        QUIT

 +4       ;

DIRECT    ;

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

 +2        IF BLRRES'=""

               SET BLRBTN="DIRECT INTERPRETATION"

               DO LOOKBTN

 +3        IF BLRRES'="P"

               QUIT

 +4        IF '$DATA(^LR(LRDFN,"BB",BLRIDT,"EA"))

               QUIT

 +5       ;S BLRPAR=$O(^BLRTXLOG("AOB",BLRACCN,BLRBTN,""))

 +6       ;IHS/DIR TUC/AAB 05/07/98

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

 +7        SET BLRANTI=0

FOR

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

               IF BLRANTI=""

                   QUIT

               SET BLRRES="POS"

               DO LOOKANT

 +8        QUIT

 +9       ;

INDIR     ;

 +1        SET BLRBTN="INDIRECT INTERPRETATION"

           DO LOOKBTN

 +2        IF BLRRES="N"

               QUIT

 +3        IF '$DATA(^LR(LRDFN,"BB",BLRIDT,5))

               QUIT

 +4       ;S BLRPAR=$O(^BLRTXLOG("AOB",BLRACCN,BLRBTN,""))

 +5       ;IHS/DIR TUC/AAB 05/07/98

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

 +6        SET BLRANTI=0

FOR

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

               IF BLRANTI=""

                   QUIT

               SET BLRRES="POS"

               DO LOOKANT

 +7        QUIT

LOOKBTN   ;

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

 +2       ;IHS/DIR TUC/AAB 05/07/98

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

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

               DO SET

               QUIT

 +3        DO BLDMSTR

 +4        QUIT

 +5       ;

LOOKANT   ;

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

               DO SET

               QUIT

 +2        DO BLDMSTR

 +3        QUIT

 +4       ;

BLDMSTR   ;

 +1        IF BLR60F

               SET BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRACCN,BLRTEST)~STATUS FLAG_BLRPHASE"

 +2        IF 'BLR60F

               Begin DoDot:1

 +3                SET BLRSTR="SEQUENCE NUMBER_$$GETBIEN(BLRACCN,BLRBTN"_$SELECT(BLRANTI="":")",1:",BLRANTI)~ANTIBODY_BLRANTI")_"~STATUS FLAG_BLRPHASE~RESULT_BLRRES~BB TEST NAME_BLRBTN"

 +4                IF BLRCMTS'=""

                       SET BLRSTR=BLRSTR_"~COMMENTS_BLRCMTS"

               End DoDot:1

 +5        DO ^BLRFLTL("M",BLRSTR)

 +6        SET BLRCMTS=""

 +7        QUIT

 +8       ;

 +9       ;

SET       ;

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

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

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

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

           SET BLRDUZ2=DUZ(2)

 +3        SET BLRDUZN=$SELECT($DATA(^VA(200,BLRDUZ,0)):$PIECE(^(0),U,1),1:"UNK"_BLRDUZ)

 +4        SET BLRDTC=$PIECE($PIECE(BLRVAL,U,8),".")

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

 +5        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=""

 +6        SET BLRCLNC=""

           IF BLRLOC'=""

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

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

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

 +9       ;----- BEGIN IHS MODIFICATINS LR*5.2*1018

 +10       SET BLRCAT="A"

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

           IF X]""

               IF X'["OBSERVATION"

                   SET BLRCAT="I"

 +11      ;----- END IHS MODIFICATIONS  MOD SENT IN BY LINDA FELS

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

           IF +BLRPROV>0

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

           IF BLRPROVN=""

               SET BLRPROVN="Unknown Provider"

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

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

           SET BLRODTM=$GET(BLRODTM)

 +14       SET BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRODTM,BLRSEQ,BLRTEST)~STATUS FLAG_BLRPHASE~LAB MODULE_""BB""~"

 +15       SET BLRSTR=BLRSTR_"LRFILE_BLRFILE~LRDFN_BLRLRDFN~PATIENT POINTER VALUE_BLRDFN~ORDERING PROVIDER POINTER_BLRPROV~VERIFIER POINTER_BLRDUZ~"

 +16       SET BLRSTR=BLRSTR_"ORDER DATE_$P(BLRVAL,U,5)~ORDER SEQ. NUMBER_BLRSEQ~ORDERING PROVIDER NAME_BLRPROVN~ORDER NUMBER_^LRO(69,BLRODT,1,BLRSEQ,.1)~"

 +17       SET BLRSTR=BLRSTR_"COLLECTION DATE/TIME_BLRDTC~VERIFIER NAME_BLRDUZN~ORDERING LOCATION NAME_BLRLOCN~ENTRY DATE/TIME_BLR(""ORDER DATE"")~CLINIC STOP CODE POINTER_BLRCLNC~"

 +18       SET BLRSTR=BLRSTR_"ORDERING LOCATION POINTER_BLRLOC~DUZ(2)_BLRDUZ2~I/O CATEGORY_BLRCAT~ACCESSION NUMBER_BLRACCN~SITE/SPECIMEN POINTER_BLRSPEC~"

 +19      ;

 +20      ;S (BLRXII,BLRCPTS,BLRCPTP)="" F  S BLRFOUND=0,BLRXII=$O(^BLRCPT("C",BLRTEST,BLRXII)) Q:(BLRXII=""!(BLRFOUND))  S BLRCPTF=$P(^BLRCPT(BLRXII,1),U,2) Q:BLRCPTF  D GETCPT Q

 +21       SET BLRTEST1=BLRTEST

           DO CPTCODE^BLRSLTL1

 +22       SET BLRSTR1="PARENT POINTER_BLRPAR~CPT LAB CODE POINTER_BLRCPTP~CPT CODE_BLRCPTS~RESULT_BLRRES~BB TEST NAME_BLRBTN~PANEL/TEST POINTER_BLRTEST"

 +23       IF BLRANTI'=""

               SET BLRSTR1=BLRSTR1_"~ANTIBODY_BLRANTI"

 +24       DO ^BLRFLTL("C",BLRSTR_BLRSTR1)

 +25       SET BLRCMTS=""

 +26       QUIT

 +27      ;

 +28      ;

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,BLRACCN,BLRANTI,BLRBTN,BLRCAT,BLRCLNC,BLRCMTS,BLRCPTC,BLRCPTF,BLRCPTP,BLRCPTS,BLRCST,BLRDFN,BLRDTC,BLRDUZ,BLRDUZ2,BLRDUZN,BLRENT,BLRFID,BLRFILE,BLRFOUND

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

 +3        KILL BLRTESTN,BLRVAL,BLRXII

 +4        QUIT

BLRBLTL.m