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
Q
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
Q
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)
Q
;
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
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 Nov 22, 2024@17:21 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
