LRBLP ;AVAMC/REG - BLOOD BANK PATIENT OPTS ;4/11/94 07:55 ;
;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
B Q D END,Z G:Y=-1 END W !!?10,"Edit transfusions entered via Previous records option" K DIC D ^LRDPA G:LRDFN=-1 END
K ^TMP($J) S (E,B)=0 F A=0:0 S A=$O(^LR(LRDFN,1.6,A)) Q:'A I $P(^(A,0),"^",9) S B=B+1,X=^(0),^TMP($J,B)=A_"^"_X D C Q:E["^"
I '$D(^TMP($J)) W $C(7),!,"There are no transfusion records entered via previous records option." G B
E W !,"Select from (1-",B,"): " R X:DTIME G:X["^"!(X="") B I X<1!(X>B)!(+X'=X) W $C(7),!,"Enter a number from 1 - ",B," to edit selection." G E
K DA S LRI=+^TMP($J,X),DIE="^LR(",DA=LRDFN,DR="[LRBLSPP]" D ^DIE G B
;
C S Y=+X,C=$P(X,"^",2) D D^LRU W !,$J(B,3),") ",Y,?25,$P(X,"^",3)," ",$P(X,"^",5)," ",$P(X,"^",6)," " I C,$D(^LAB(66,C,0)) W $P(^(0),"^") D:B#20=0 M Q
;
O Q D END,Z G:Y=-1 END W !!?10,"Blood bank patient data from old records"
PT K DIC,DA W ! D ^LRDPA G:LRDFN=-1 END S DIE="^LR(",DA=LRDFN,DR="[LRBLPOLD]" D ^DIE
F W=0:0 S W=$O(W(W)) Q:'W F M=0:0 S M=$O(W(W,M)) Q:'M I '$D(^LR(LR,W,M)) S O=M,X="deleted",Z=W(W,M)_",.01" D EN^LRUD
K M,W,O,LR,DIE,DR,DA S:'$D(^LR(LRDFN,1.6,0)) ^(0)="^63.017DAI^^"
ASK W ! S DA(1)=LRDFN,DIC="^LR(LRDFN,1.6,",DIC(0)="AEQL",DLAYGO=63 D ^DIC K DIC,DLAYGO G:Y<1 PT I '$P(Y,U,3) W $C(7),!,"For new entries only. No editing." G ASK
K DA S LRI=+Y,DA=LRDFN,DIE="^LR(",DR="[LRBLPT]" D ^DIE G ASK
S W !!?10,"Blood bank patient special instructions" K DIC W ! D ^LRDPA G:LRDFN=-1 END S DIE="^LR(",DA=LRDFN,DR=".076" W ! D ^DIE G S
P Q I $D(LRLOKVAR) D FRE^LRU
D END,Z W !!?25,"Edit blood bank patient ABO/Rh" K DIC,DA D ^LRDPA G:LRDFN<1 END S DIE="^LR(",DA=LRDFN,X=^LR(LRDFN,0),LRABO=$P(X,U,5),LRRH=$P(X,U,6) D CK^LRU G:$D(LR("CK")) P
ABO S LRP=5,Z="63,.05",LRF=$P(^DD(63,.05,0),U,3) W !!,"ABO GROUP: ",LRABO,$S(LRABO]"":"// ",1:" ") R X:DTIME G:'$T!(X[U) P S:X="" X=LRABO S LRD=LRABO D F G:Y="" ABO
RH S LRP=6,Z="63,.06",LRF=$P(^DD(63,.06,0),U,3) W !!,"RH TYPE: ",LRRH,$S(LRRH]"":"// ",1:" ") R X:DTIME G:'$T!(X[U) P S:X="" X=LRRH S A=$S($A(X)=80:$P("POS",X,2),1:$P("NEG",X,2)),X=X_A,LRD=LRRH W A D F G:Y="" RH
G P
;
TX Q D END,Z G:Y=-1 END W !!?8,"Enter/edit transfusion reactions that do not have specific",!?18,"units associated with the reaction",!
T K DIC W ! D ^LRDPA G:LRDFN=-1 END S:'$D(^LR(LRDFN,1.9,0)) ^(0)="^63.0171DAI^^" S DIC="^LR(LRDFN,1.9,",DIC(0)="AEQLMZ",DLAYGO=63 W ! D ^DIC K DIC,DLAYGO G:Y<1 T S LR=Y(0),LRI=+Y
W ! S DIE="^LR(",DA=LRDFN,DR="[LRBLPTXR]" D ^DIE I '$D(^LR(LRDFN,1.9,LRI,0)) S O=$P(LR,U),X="Deleted",Z="63.0171,.01" D EN^LRUD
G T
;
F I X="@",LRD="" W $C(7)," NOTHING TO DELETE !" S Y="" Q
I X="@" F A=1.8,1,1.7,3,1.5,1.6 I $O(^LR(LRDFN,A,0)) S LRK=1 Q
I X="@",$D(^LRD(65,"AP",LRDFN)) W $C(7),!!,"Units assigned/crossmatched." S LRK=1
I $D(LRK) K LRK W !!,$C(7),"Any component requests, units assigned/crossmatched, transfusion records,",!,"RBC antigens present or absent, antibodies identified or blood bank comments",!,"must be removed before deletion allowed.",! S Y="" Q
S LRI=$O(^LR(LRDFN,"BB",0)) I X="@",LRI D A I $D(LRK) W $C(7),!!,"Blood bank data entered for this patient. Deletion not allowed!",! S Y="" Q
I $D(LRM) K LRM Q
I X="@" W $C(7),!,"ARE YOU SURE YOU WANT TO DELETE " S %=2 D YN^LRU I %=1 S $P(^LR(LRDFN,0),"^",LRP)="",O=LRD,X="deleted" D EN^LRUD S Y="@" Q
Q:X="@"!(X="") S X=X_":",Y=$P($P(LRF,X,2),";") I Y]"",LRD'=Y S $P(^LR(LRDFN,0),"^",LRP)=Y,X=Y,O=LRD D EN^LRUD
Q:Y]"" W !?5,"CHOOSE FROM: " F X=1:1 S Y=$P(LRF,";",X) Q:Y="" S A=$P(Y,":",2),Y=$P(Y,":",1) W !?7,Y,?15," ",A
S Y="" Q
A K LRK I $P(^LR(LRDFN,"BB",0),"^",4)>1 S LRK=1 Q
Q:$D(LRK) S X=^LR(LRDFN,"BB",LRI,0),$P(^(0),"^",3)="" W $C(7),!!,"Remove blood bank accession number ",$P(X,"^",6),!,"And then you can delete the ABO & RH entries.",! S LRM=1 Q
;
Z S X="BLOOD BANK" D ^LRUTL Q
M W !,"'^' TO STOP: " R E:DTIME Q:E["^"
W $C(13),$J("",15),$C(13) Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLP 4052 printed Sep 23, 2025@19:47:16 Page 2
LRBLP ;AVAMC/REG - BLOOD BANK PATIENT OPTS ;4/11/94 07:55 ;
+1 ;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
B QUIT
DO END
DO Z
if Y=-1
GOTO END
WRITE !!?10,"Edit transfusions entered via Previous records option"
KILL DIC
DO ^LRDPA
if LRDFN=-1
GOTO END
+1 KILL ^TMP($JOB)
SET (E,B)=0
FOR A=0:0
SET A=$ORDER(^LR(LRDFN,1.6,A))
if 'A
QUIT
IF $PIECE(^(A,0),"^",9)
SET B=B+1
SET X=^(0)
SET ^TMP($JOB,B)=A_"^"_X
DO C
if E["^"
QUIT
+2 IF '$DATA(^TMP($JOB))
WRITE $CHAR(7),!,"There are no transfusion records entered via previous records option."
GOTO B
E WRITE !,"Select from (1-",B,"): "
READ X:DTIME
if X["^"!(X="")
GOTO B
IF X<1!(X>B)!(+X'=X)
WRITE $CHAR(7),!,"Enter a number from 1 - ",B," to edit selection."
GOTO E
+1 KILL DA
SET LRI=+^TMP($JOB,X)
SET DIE="^LR("
SET DA=LRDFN
SET DR="[LRBLSPP]"
DO ^DIE
GOTO B
+2 ;
C SET Y=+X
SET C=$PIECE(X,"^",2)
DO D^LRU
WRITE !,$JUSTIFY(B,3),") ",Y,?25,$PIECE(X,"^",3)," ",$PIECE(X,"^",5)," ",$PIECE(X,"^",6)," "
IF C
IF $DATA(^LAB(66,C,0))
WRITE $PIECE(^(0),"^")
if B#20=0
DO M
QUIT
+1 ;
O QUIT
DO END
DO Z
if Y=-1
GOTO END
WRITE !!?10,"Blood bank patient data from old records"
PT KILL DIC,DA
WRITE !
DO ^LRDPA
if LRDFN=-1
GOTO END
SET DIE="^LR("
SET DA=LRDFN
SET DR="[LRBLPOLD]"
DO ^DIE
+1 FOR W=0:0
SET W=$ORDER(W(W))
if 'W
QUIT
FOR M=0:0
SET M=$ORDER(W(W,M))
if 'M
QUIT
IF '$DATA(^LR(LR,W,M))
SET O=M
SET X="deleted"
SET Z=W(W,M)_",.01"
DO EN^LRUD
+2 KILL M,W,O,LR,DIE,DR,DA
if '$DATA(^LR(LRDFN,1.6,0))
SET ^(0)="^63.017DAI^^"
ASK WRITE !
SET DA(1)=LRDFN
SET DIC="^LR(LRDFN,1.6,"
SET DIC(0)="AEQL"
SET DLAYGO=63
DO ^DIC
KILL DIC,DLAYGO
if Y<1
GOTO PT
IF '$PIECE(Y,U,3)
WRITE $CHAR(7),!,"For new entries only. No editing."
GOTO ASK
+1 KILL DA
SET LRI=+Y
SET DA=LRDFN
SET DIE="^LR("
SET DR="[LRBLPT]"
DO ^DIE
GOTO ASK
S WRITE !!?10,"Blood bank patient special instructions"
KILL DIC
WRITE !
DO ^LRDPA
if LRDFN=-1
GOTO END
SET DIE="^LR("
SET DA=LRDFN
SET DR=".076"
WRITE !
DO ^DIE
GOTO S
P QUIT
IF $DATA(LRLOKVAR)
DO FRE^LRU
+1 DO END
DO Z
WRITE !!?25,"Edit blood bank patient ABO/Rh"
KILL DIC,DA
DO ^LRDPA
if LRDFN<1
GOTO END
SET DIE="^LR("
SET DA=LRDFN
SET X=^LR(LRDFN,0)
SET LRABO=$PIECE(X,U,5)
SET LRRH=$PIECE(X,U,6)
DO CK^LRU
if $DATA(LR("CK"))
GOTO P
ABO SET LRP=5
SET Z="63,.05"
SET LRF=$PIECE(^DD(63,.05,0),U,3)
WRITE !!,"ABO GROUP: ",LRABO,$SELECT(LRABO]"":"// ",1:" ")
READ X:DTIME
if '$TEST!(X[U)
GOTO P
if X=""
SET X=LRABO
SET LRD=LRABO
DO F
if Y=""
GOTO ABO
RH SET LRP=6
SET Z="63,.06"
SET LRF=$PIECE(^DD(63,.06,0),U,3)
WRITE !!,"RH TYPE: ",LRRH,$SELECT(LRRH]"":"// ",1:" ")
READ X:DTIME
if '$TEST!(X[U)
GOTO P
if X=""
SET X=LRRH
SET A=$SELECT($ASCII(X)=80:$PIECE("POS",X,2),1:$PIECE("NEG",X,2))
SET X=X_A
SET LRD=LRRH
WRITE A
DO F
if Y=""
GOTO RH
+1 GOTO P
+2 ;
TX QUIT
DO END
DO Z
if Y=-1
GOTO END
WRITE !!?8,"Enter/edit transfusion reactions that do not have specific",!?18,"units associated with the reaction",!
T KILL DIC
WRITE !
DO ^LRDPA
if LRDFN=-1
GOTO END
if '$DATA(^LR(LRDFN,1.9,0))
SET ^(0)="^63.0171DAI^^"
SET DIC="^LR(LRDFN,1.9,"
SET DIC(0)="AEQLMZ"
SET DLAYGO=63
WRITE !
DO ^DIC
KILL DIC,DLAYGO
if Y<1
GOTO T
SET LR=Y(0)
SET LRI=+Y
+1 WRITE !
SET DIE="^LR("
SET DA=LRDFN
SET DR="[LRBLPTXR]"
DO ^DIE
IF '$DATA(^LR(LRDFN,1.9,LRI,0))
SET O=$PIECE(LR,U)
SET X="Deleted"
SET Z="63.0171,.01"
DO EN^LRUD
+2 GOTO T
+3 ;
F IF X="@"
IF LRD=""
WRITE $CHAR(7)," NOTHING TO DELETE !"
SET Y=""
QUIT
+1 IF X="@"
FOR A=1.8,1,1.7,3,1.5,1.6
IF $ORDER(^LR(LRDFN,A,0))
SET LRK=1
QUIT
+2 IF X="@"
IF $DATA(^LRD(65,"AP",LRDFN))
WRITE $CHAR(7),!!,"Units assigned/crossmatched."
SET LRK=1
+3 IF $DATA(LRK)
KILL LRK
WRITE !!,$CHAR(7),"Any component requests, units assigned/crossmatched, transfusion records,",!,"RBC antigens present or absent, antibodies identified or blood bank comments",!,"must be removed before deletion allowed.",!
SET Y=""
QUIT
+4 SET LRI=$ORDER(^LR(LRDFN,"BB",0))
IF X="@"
IF LRI
DO A
IF $DATA(LRK)
WRITE $CHAR(7),!!,"Blood bank data entered for this patient. Deletion not allowed!",!
SET Y=""
QUIT
+5 IF $DATA(LRM)
KILL LRM
QUIT
+6 IF X="@"
WRITE $CHAR(7),!,"ARE YOU SURE YOU WANT TO DELETE "
SET %=2
DO YN^LRU
IF %=1
SET $PIECE(^LR(LRDFN,0),"^",LRP)=""
SET O=LRD
SET X="deleted"
DO EN^LRUD
SET Y="@"
QUIT
+7 if X="@"!(X="")
QUIT
SET X=X_":"
SET Y=$PIECE($PIECE(LRF,X,2),";")
IF Y]""
IF LRD'=Y
SET $PIECE(^LR(LRDFN,0),"^",LRP)=Y
SET X=Y
SET O=LRD
DO EN^LRUD
+8 if Y]""
QUIT
WRITE !?5,"CHOOSE FROM: "
FOR X=1:1
SET Y=$PIECE(LRF,";",X)
if Y=""
QUIT
SET A=$PIECE(Y,":",2)
SET Y=$PIECE(Y,":",1)
WRITE !?7,Y,?15," ",A
+9 SET Y=""
QUIT
A KILL LRK
IF $PIECE(^LR(LRDFN,"BB",0),"^",4)>1
SET LRK=1
QUIT
+1 if $DATA(LRK)
QUIT
SET X=^LR(LRDFN,"BB",LRI,0)
SET $PIECE(^(0),"^",3)=""
WRITE $CHAR(7),!!,"Remove blood bank accession number ",$PIECE(X,"^",6),!,"And then you can delete the ABO & RH entries.",!
SET LRM=1
QUIT
+2 ;
Z SET X="BLOOD BANK"
DO ^LRUTL
QUIT
M WRITE !,"'^' TO STOP: "
READ E:DTIME
if E["^"
QUIT
+1 WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
QUIT
+2 ;
END DO V^LRU
QUIT
