Routine: LRBLDT

LRBLDT ;AVAMC/REG/CYM - DONOR UNIT TESTING ;7/5/96  08:35 ;

 ;;5.2;LAB SERVICE;**72,97,247,408**;Sep 27, 1994;Build 8

 ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021

 Q  D V^LRU S X="BLOOD BANK" D ^LRUTL G:Y=-1 END D D^LRBLU G:'$D(X) END

 I LRCAPA S X="DONOR ANTIBODY SCREEN" D X^LRUWK G:'$D(X) END S Y="DT" D S^LRBLWD D EN^LRBLW G:%<1 END W:%=2 ! I $D(LRK("LRK")) D DT^LRBLU S LRK("LRK")=LRK

 F A=12:1:20 D SC

SEL W !!,"Select test(s) by number: " R X:DTIME G:X=""!(X[U) END I X["?" W !,"Enter one or more of the above numbers",!,"For 2 or more selections separate each with a ',' (ex. 12,13,15)",!,"Enter 'ALL' for all tests." G SEL

 I X="ALL" D ALL G SHOW

 I X?.E1CA.E!($L(X)>200) W $C(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed." G SEL

 I '+X W $C(7),!,"START with a NUMBER !!",! G SEL

 S Y=X F LRB=0:0 S LRV=+Y,Y=$E(Y,$L(LRV)+2,$L(Y)) S:$D(LRA(LRV)) LRF(LRV)=LRA(LRV) Q:'$L(Y)

SHOW I '$D(LRF) W $C(7),!,"None of the listed tests selected, try again " S %=1 D YN^LRU G LRBLDT:%=1,END

 W !!,"You have selected the following tests:" F A=0:0 S A=$O(LRF(A)) Q:'A  W !,$J(A,3),") ",LRF(A)

 W !,"OK " S %=1 D YN^LRU G:%'=1 LRBLDT S LRB="",LRC=1 W !!,"Enter TEST COMMENT(s) " S %=2 D YN^LRU G:%<1 END K:%=1 LRC

DNR W ! K DA,LRZ,LRR S DIC="^LRE(",DIC(0)="AFQM",D="C^B",DIC("B")=LRB,DIC("A")="Select DONOR ID: " D MIX^DIC1 K DIC G:X=""!(X[U) END

 I Y<1 W $C(7),!!,"Complete DONOR ID must be entered (ex. If ID=H12345 then H123 unacceptable)." G DNR

 I X["," D ASK G:Y<1 DNR D CKRL,REST G DNR

 S LRQ=+Y,LRI=$O(^LRE("C",X,LRQ,0)) I 'LRI W $C(7),"  ",X," does not exist, try again" G DNR

 L +^LRE(LRQ,5,LRI,0):5 I '$T W !!,$C(7),"Someone else is editing this record." G DNR

 S LRQ(1)=$P(^LRE(LRQ,5,LRI,0),"^",4) D CKRL,REST L -^LRE(LRQ,5,LRI,0) G DNR

REST S X(1)=$E(X,3,$L(X)),X(2)=X(1)+1,X(3)=$L(X(1))-$L(X(2)) I X(3) S X(2)=$E("00000",1,X(3))_X(2)

 S LRB=$E(X,1,2)_X(2),LRB=$S($D(^LRE("C",LRB)):LRB,1:"")

 S X=^LRE(LRQ,0),W(5)=$P(X,U,5),W(6)=$P(X,U,6)

 S Y=+^LRE(LRQ,5,LRI,0) D D^LRU W !!,"UNIT#:",LRQ(1),"  ABO:",W(5)," Rh:",W(6),"  Donation date:",Y I LRQ(1)="" W $C(7),!?35,"Must have UNIT # to proceed." Q

 W ! S LR(65.54,15)="",DR="[LRBLDT]",DIE="^LRE(",DA=LRQ D ^DIE K DIE,DR

 I $D(LRR) S B=3 F A=0:0 S A=$O(LRA(A)) Q:'A  I $D(^LRE(LRQ,5,LRI,A)),$P(^(A),"^") S LRZ=1,B=B+1,Y=^(A),X=+Y,X=$$EXTERNAL^DILFD(65.54,A,"",X),LR("TXT",B,0)=LRA(A)_":"_X_" "_$P(Y,"^",3)

 I $D(LRZ) D MSG K LRZ

 I $D(LRR),'$D(^XUSEC("LRBLSUPER",DUZ)) W !,"One or more components were released.  You may not edit existing test results."

 I LR(65.54,15)=0!(LR(65.54,15)) S Y="DT" D:LRCAPA SET^LRBLWD

S ;from LRBLDT input template only supervisor can edit data after release of components

 I $D(LRR),$P(LRM,U)!($P(LRM,U)=0),'$D(^XUSEC("LRBLSUPER",DUZ)) S Y=Z

ASK S LRQ=+Y,DIC="^LRE(LRQ,5,",DIC(0)="FAEQM",DIC("A")="Select DONATION DATE: " D ^DIC K DIC Q:Y<1

 S LRI=+Y,LRQ(1)=$P(^LRE(LRQ,5,LRI,0),U,4) Q

R W !,"Add ",LRF(A)," to donor testing worklist " S %=2 D YN^LRU Q:%'=1  S ^LRE("AT",LRQ(1),A,LRQ,LRI)="" Q

D K ^LRE("AT",LRQ(1),A,LRQ,LRI) Q

ALL F A=0:0 S A=$O(LRA(A)) Q:'A  S LRF(A)=LRA(A)

CKRL F A=0:0 S A=$O(^LRE(LRQ,5,LRI,66,A)) Q:'A  I $P(^(A,0),"^",8)=0 S LRR=1 Q

MSG S LR("TXT",2,0)="Component(s) released with one or more positive test results!",LR("TXT",1,0)="Blood donor unit ID: "_LRQ(1),LR("KEY")="LRBLSUPER",LR("SUB")="Release of donor unit with abnormal test results"

 N NAME,TYPE S X=$P(^LRE(LRQ,5,LRI,0),U,11) D FIELD^DID(65.54,1.1,"","LABEL","NAME") S NAME=NAME("LABEL")

 S TYPE=$$EXTERNAL^DILFD(65.54,1.1,"",X)

 S LR("TXT",3,0)=NAME_":  "_TYPE

 W $C(7),!!,LR("TXT",2,0) D ^LRUMSG Q

END D V^LRU Q

SC I A'=17&(A'=20) D W Q

 D:$G(LRH(A)) W Q

W D FIELD^DID(65.54,A,"","LABEL","LRA") S LRA(A)=LRA("LABEL") W !,$J(A,3),")  ",LRA(A) Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDT   3874     printed  Mar 13, 2025@21:15:16                                                                                                                                                                                                      Page 2

LRBLDT    ;AVAMC/REG/CYM - DONOR UNIT TESTING ;7/5/96  08:35 ;

 +1       ;;5.2;LAB SERVICE;**72,97,247,408**;Sep 27, 1994;Build 8

 +2       ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021

 +3        QUIT

           DO V^LRU

           SET X="BLOOD BANK"

           DO ^LRUTL

           if Y=-1

               GOTO END

           DO D^LRBLU

           if '$DATA(X)

               GOTO END

 +4        IF LRCAPA

               SET X="DONOR ANTIBODY SCREEN"

               DO X^LRUWK

               if '$DATA(X)

                   GOTO END

               SET Y="DT"

               DO S^LRBLWD

               DO EN^LRBLW

               if %<1

                   GOTO END

               if %=2

                   WRITE !

               IF $DATA(LRK("LRK"))

                   DO DT^LRBLU

                   SET LRK("LRK")=LRK

 +5        FOR A=12:1:20

               DO SC

SEL        WRITE !!,"Select test(s) by number: "

           READ X:DTIME

           if X=""!(X[U)

               GOTO END

           IF X["?"

               WRITE !,"Enter one or more of the above numbers",!,"For 2 or more selections separate each with a ',' (ex. 12,13,15)",!,"Enter 'ALL' for all tests."

               GOTO SEL

 +1        IF X="ALL"

               DO ALL

               GOTO SHOW

 +2        IF X?.E1CA.E!($LENGTH(X)>200)

               WRITE $CHAR(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed."

               GOTO SEL

 +3        IF '+X

               WRITE $CHAR(7),!,"START with a NUMBER !!",!

               GOTO SEL

 +4        SET Y=X

           FOR LRB=0:0

               SET LRV=+Y

               SET Y=$EXTRACT(Y,$LENGTH(LRV)+2,$LENGTH(Y))

               if $DATA(LRA(LRV))

                   SET LRF(LRV)=LRA(LRV)

               if '$LENGTH(Y)

                   QUIT

SHOW       IF '$DATA(LRF)

               WRITE $CHAR(7),!,"None of the listed tests selected, try again "

               SET %=1

               DO YN^LRU

               if %=1

                   GOTO LRBLDT

               GOTO END

 +1        WRITE !!,"You have selected the following tests:"

           FOR A=0:0

               SET A=$ORDER(LRF(A))

               if 'A

                   QUIT

               WRITE !,$JUSTIFY(A,3),") ",LRF(A)

 +2        WRITE !,"OK "

           SET %=1

           DO YN^LRU

           if %'=1

               GOTO LRBLDT

           SET LRB=""

           SET LRC=1

           WRITE !!,"Enter TEST COMMENT(s) "

           SET %=2

           DO YN^LRU

           if %<1

               GOTO END

           if %=1

               KILL LRC

DNR        WRITE !

           KILL DA,LRZ,LRR

           SET DIC="^LRE("

           SET DIC(0)="AFQM"

           SET D="C^B"

           SET DIC("B")=LRB

           SET DIC("A")="Select DONOR ID: "

           DO MIX^DIC1

           KILL DIC

           if X=""!(X[U)

               GOTO END

 +1        IF Y<1

               WRITE $CHAR(7),!!,"Complete DONOR ID must be entered (ex. If ID=H12345 then H123 unacceptable)."

               GOTO DNR

 +2        IF X[","

               DO ASK

               if Y<1

                   GOTO DNR

               DO CKRL

               DO REST

               GOTO DNR

 +3        SET LRQ=+Y

           SET LRI=$ORDER(^LRE("C",X,LRQ,0))

           IF 'LRI

               WRITE $CHAR(7),"  ",X," does not exist, try again"

               GOTO DNR

 +4        LOCK +^LRE(LRQ,5,LRI,0):5

           IF '$TEST

               WRITE !!,$CHAR(7),"Someone else is editing this record."

               GOTO DNR

 +5        SET LRQ(1)=$PIECE(^LRE(LRQ,5,LRI,0),"^",4)

           DO CKRL

           DO REST

           LOCK -^LRE(LRQ,5,LRI,0)

           GOTO DNR

 +6       ;

REST       SET X(1)=$EXTRACT(X,3,$LENGTH(X))

           SET X(2)=X(1)+1

           SET X(3)=$LENGTH(X(1))-$LENGTH(X(2))

           IF X(3)

               SET X(2)=$EXTRACT("00000",1,X(3))_X(2)

 +1        SET LRB=$EXTRACT(X,1,2)_X(2)

           SET LRB=$SELECT($DATA(^LRE("C",LRB)):LRB,1:"")

 +2        SET X=^LRE(LRQ,0)

           SET W(5)=$PIECE(X,U,5)

           SET W(6)=$PIECE(X,U,6)

 +3        SET Y=+^LRE(LRQ,5,LRI,0)

           DO D^LRU

           WRITE !!,"UNIT#:",LRQ(1),"  ABO:",W(5)," Rh:",W(6),"  Donation date:",Y

           IF LRQ(1)=""

               WRITE $CHAR(7),!?35,"Must have UNIT # to proceed."

               QUIT

 +4        WRITE !

           SET LR(65.54,15)=""

           SET DR="[LRBLDT]"

           SET DIE="^LRE("

           SET DA=LRQ

           DO ^DIE

           KILL DIE,DR

 +5        IF $DATA(LRR)

               SET B=3

               FOR A=0:0

                   SET A=$ORDER(LRA(A))

                   if 'A

                       QUIT

                   IF $DATA(^LRE(LRQ,5,LRI,A))

                       IF $PIECE(^(A),"^")

                           SET LRZ=1

                           SET B=B+1

                           SET Y=^(A)

                           SET X=+Y

                           SET X=$$EXTERNAL^DILFD(65.54,A,"",X)

                           SET LR("TXT",B,0)=LRA(A)_":"_X_" "_$PIECE(Y,"^",3)

 +6        IF $DATA(LRZ)

               DO MSG

               KILL LRZ

 +7        IF $DATA(LRR)

               IF '$DATA(^XUSEC("LRBLSUPER",DUZ))

                   WRITE !,"One or more components were released.  You may not edit existing test results."

 +8        IF LR(65.54,15)=0!(LR(65.54,15))

               SET Y="DT"

               if LRCAPA

                   DO SET^LRBLWD

 +9        QUIT

S         ;from LRBLDT input template only supervisor can edit data after release of components

 +1        IF $DATA(LRR)

               IF $PIECE(LRM,U)!($PIECE(LRM,U)=0)

                   IF '$DATA(^XUSEC("LRBLSUPER",DUZ))

                       SET Y=Z

 +2        QUIT

ASK        SET LRQ=+Y

           SET DIC="^LRE(LRQ,5,"

           SET DIC(0)="FAEQM"

           SET DIC("A")="Select DONATION DATE: "

           DO ^DIC

           KILL DIC

           if Y<1

               QUIT

 +1        SET LRI=+Y

           SET LRQ(1)=$PIECE(^LRE(LRQ,5,LRI,0),U,4)

           QUIT

 +2       ;

R          WRITE !,"Add ",LRF(A)," to donor testing worklist "

           SET %=2

           DO YN^LRU

           if %'=1

               QUIT

           SET ^LRE("AT",LRQ(1),A,LRQ,LRI)=""

           QUIT

 +1       ;

D          KILL ^LRE("AT",LRQ(1),A,LRQ,LRI)

           QUIT

 +1       ;

ALL        FOR A=0:0

               SET A=$ORDER(LRA(A))

               if 'A

                   QUIT

               SET LRF(A)=LRA(A)

 +1        QUIT

 +2       ;

CKRL       FOR A=0:0

               SET A=$ORDER(^LRE(LRQ,5,LRI,66,A))

               if 'A

                   QUIT

               IF $PIECE(^(A,0),"^",8)=0

                   SET LRR=1

                   QUIT

 +1        QUIT

MSG        SET LR("TXT",2,0)="Component(s) released with one or more positive test results!"

           SET LR("TXT",1,0)="Blood donor unit ID: "_LRQ(1)

           SET LR("KEY")="LRBLSUPER"

           SET LR("SUB")="Release of donor unit with abnormal test results"

 +1        NEW NAME,TYPE

           SET X=$PIECE(^LRE(LRQ,5,LRI,0),U,11)

           DO FIELD^DID(65.54,1.1,"","LABEL","NAME")

           SET NAME=NAME("LABEL")

 +2        SET TYPE=$$EXTERNAL^DILFD(65.54,1.1,"",X)

 +3        SET LR("TXT",3,0)=NAME_":  "_TYPE

 +4        WRITE $CHAR(7),!!,LR("TXT",2,0)

           DO ^LRUMSG

           QUIT

END        DO V^LRU

           QUIT

SC         IF A'=17&(A'=20)

               DO W

               QUIT

 +1        if $GET(LRH(A))

               DO W

           QUIT

W          DO FIELD^DID(65.54,A,"","LABEL","LRA")

           SET LRA(A)=LRA("LABEL")

           WRITE !,$JUSTIFY(A,3),")  ",LRA(A)

           QUIT

LRBLDT.m