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)
D
.I DR["CMBS" D COOMBS Q
.D RHTYP
I BLRBTN'="" S BLRRES="",BLR60F=1 D BLDMSTR
D KILL
Q
;
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
Q
;
COOMBS ;
I $D(^LR(LRDFN,"BB",BLRIDT,2)) D DIRECT
I $D(^LR(LRDFN,"BB",BLRIDT,6)) S BLRRES=^(6) D INDIR
Q
;
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
Q
;
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
Q
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
Q
;
LOOKANT ;
I '$D(^BLRTXLOG("AOA",BLRACCN,BLRBTN,BLRANTI)) D SET Q
D BLDMSTR
Q
;
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=""
Q
;
;
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=""
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,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
Q
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
