- 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 Feb 18, 2025@23:37:30 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
