- LRBLU ;AVAMC/REG/CYM - BB UTIL ;1/22/97 15:32 ;
- ;;5.2;LAB SERVICE;**97,90,247**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- ;
- K:$L(X)<6!($L(X)>11)!(X'?.UN) X ;input trans ^DD(65.54,4,
- I $D(X),$D(^LRE("C",X)) S W=X(1)+50000 F Y=0:0 Q:'$D(X) S Y=$O(^LRE("C",X,Y)) Q:'Y K:'$D(^LRE(Y,0)) ^LRE("C",X,Y) I $D(^LRE("C",X,Y)) D I
- Q:'$D(X) I $D(^LRD(65,"B",X))!($D(^LRD(65,"C",X))) W $C(7),!?15,"INVENTORY FILE HAS AN ENTRY WITH SAME ID ! " D O
- Q
- I F Z=0:0 S Z=$O(^LRE("C",X,Y,Z)) Q:'Z I Z<W W !,$C(7),X," assigned to ",$P(^LRE(Y,0),U) K X Q
- Q
- ;
- F Q:X="" S X=$P($P(B,X_":",2),";") Q
- S ;sets C-xref in FILE 65
- S Y=^LRD(65,DA,0),S=$P(Y,U,2),C=$P(Y,U,4),A=$P(Y,U) I C,S]"" S Y=$O(^LAB(66,C,"SU","B",S,0)) S:Y Y=$L($P(^LAB(66,C,"SU",Y,0),U,10)) S:Y ^LRD(65,"C",$E(A,Y+1,$L(A)),DA)=""
- Q
- K ;Kill C-xref in FILE 65
- S LR("DEAD")=0
- S A="" F S A=$O(^LRD(65,"C",A)) Q:A=""!(LR("DEAD")) I $D(^LRD(65,"C",A,DA)) K ^LRD(65,"C",A,DA) S LR("DEAD")=1
- K LR("DEAD")
- Q
- KK S Y=^LRD(65,DA,0),S=$P(Y,U,2),C=$P(Y,U,4),A=LR(65,.01)
- I C,S]"" D
- . S Y=$O(^LAB(66,C,"SU","B",S,0))
- . S:Y Y=$L($P(^LAB(66,C,"SU",Y,0),U,10))
- I Y K ^LRD(65,"C",$E(A,Y+1,$L(A)),DA) Q
- Q
- S1 I 1
- Q
- K1 ;Kill AG x-ref DD(65,4.1,1,
- S A=^LRD(65,DA,6),Z=$P(A,U,4),A=+A
- I A,Z D
- . S B=+$P($G(^LR(A,1.6,Z,0)),U,11)
- . K ^LRD(65,"AB",$E(X,1,30),DA)
- . K ^LRD(65,DA,4),^(5),^(6),^(7),^LR(A,1.6,Z),^LR("AB",A,B,Z)
- . I $D(^LR(A,1.6,0)) S A=^(0),Z=$O(^(0)),^(0)=$P(A,U,1,2)_U_Z_U_$S('Z:Z,1:($P(A,U,4)-1))
- Q
- A ;Makes change to ^LRD(65,"AP" & date unit assigned if necessary
- I X'="C",X'="IG" K ^LRD(65,"AP",DA(1),DA(2)) S $P(^LRD(65,DA(2),2,DA(1),0),U,2)="" Q
- S ^LRD(65,"AP",DA(1),DA(2))="",X(1)=$P(^LRD(65,DA(2),2,DA(1),0),U,2) I 'X(1) S LR=X,X="N",%DT="T" D ^%DT S X=LR,$P(^LRD(65,DA(2),2,DA(1),0),U,2)=Y
- Q
- EN ;
- F A=0:0 S A=$O(^LRD(65,"B",X,A)) Q:'A I $D(LR)#2,$D(^LRD(65,A,0)),$P(^(0),U,4)=LR W $C(7),!,"UNIT IN INVENTORY - EDIT TRANSFUSION DATA THERE !" K X Q
- Q ;input transform ^DD(63.017,.03,0)
- EN1 ;
- S (DIC,DIE)="^LAB(61.3,"
- S X=0 F X(1)=0:0 S X=$O(^LAB(61.3,"B","D",X)) Q:'X I X,^(X)="" Q
- I X S (LRB,DA)=X,DR="2///50710" D ^DIE G END
- S X="D",DIC(0)="ML",DLAYGO=61 D ^DIC K DIC
- S DA=+Y,DR="2///50710" D ^DIE S LRB=$O(^LAB(61.3,"C",50710,0))
- K DLAYGO
- ;
- EN2 ;called by TRANSFUSION entry in EXECUTE CODE file
- S X="N",%DT="T" D ^%DT S X1=Y,X2=-3 D C^%DTC S X=9999999-X
- S A=0 F B=1:1 S A=$O(^LR(LRDFN,"BB",A)) Q:'A!(A>X) W:B=1 $C(7),!,"Specimen(s) received within past 72 hrs:" S Z=^(A,0),Y=+Z D DT^LRU W !,Y,?18,$P(Z,U,6)
- Q
- EN3 ;delete user print list for transfusion & hematology data
- D OUT
- S X="BLOOD BANK" D ^LRUTL
- G:'LRAA OUT
- I '$D(^LRO(69.2,LRAA,7,0)) W $C(7),!!,"There are no user lists." G OUT
- S (DIC,DIE)="^LRO(69.2,LRAA,7,",DIC(0)="AEQM" D ^DIC K DIC G:Y<1 OUT
- S DA=+Y,DA(1)=LRAA,DR=.01 D ^DIE G EN3
- D S X=$O(^LAB(69.9,1,8,"B","DONOR",0)) I 'X W $C(7),"Must define blood bank site parameters using option:",!?3,"Edit blood bank site parameters [LRBLSSP] under the Supervisor menu" K X Q
- S X=^LAB(69.9,1,8,X,0),LRH(2)=$P(X,U,3),LRH(3)=$P(X,U,4) I LRH(2)=""!(LRH(3)="") W $C(7),!!,"Must enter second and third defaults for DONOR using:",!?3,"Edit blood bank site parameters [LRBLSSP] under the Supervisor menu" K X Q
- S LRH(17)=+$P(X,U,6),LRH(20)=+$P(X,U,7) Q
- OUT D V^LRU Q
- O ;enter old donor unit (CAUTION: This unit is in inventory)
- I '$D(LRD("U")) K X Q
- W !!,"Do you still want to enter this unit in the donor file " S %=2 D YN^LRU I %=1 W !,"Ok, done." Q
- K X Q
- P ;from DD(63.01, input transforms for fields 6.1 to 6.4
- Q:'$D(^LR(LRDFN,"BB",LRI,A,X))&('$D(^LR(LRDFN,B,X)))
- W !!,$P(^LAB(61.3,X,0),U)," antigen cannot be present & absent.",! K ^LR(LRDFN,"BB",LRI,C,X) S X=^LR(LRDFN,"BB",LRI,C,0),X(1)=$O(^(0)),^(0)=$P(X,U,1,2)_U_X(1)_U_$S('X(1):"",1:($P(X,U,4)-1)) K X Q
- B ;
- S X="T",%DT="" D ^%DT,D^LRU S LRH=Y
- S %DT="AETX",%DT(0)="-N",%DT("A")="Start with Date TODAY// " D ^%DT K %DT I X="" S Y=DT W LRH
- Q:Y<1 S LRSDT=Y
- S %DT="AETX",%DT("A")="Go to Date TODAY// " D ^%DT K %DT I X="" S Y=DT W LRH
- Q:Y<1 S LRLDT=Y I LRSDT>LRLDT S X=LRSDT,LRSDT=LRLDT,LRLDT=X
- S Y=LRSDT D D^LRU S LRSTR=Y,Y=LRLDT D D^LRU S LRLST=Y K LRH Q
- DT W ! S %DT("A")="Date/time work completed: NOW// ",%DT="AEQTX",%DT(0)="-N" D ^%DT K %DT I X[U!(Y>1&(Y'[".")) W $C(7),!?35,"Not allowed, enter date and time.",!?35,"Future times not allowed." G DT
- I Y<1 S X="N",%DT="EQTX" D ^%DT K %DT
- S LRK=Y W ! Q
- ;
- END K DIC,DIE,DR,DA Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLU 4551 printed Jan 18, 2025@03:13:06 Page 2
- LRBLU ;AVAMC/REG/CYM - BB UTIL ;1/22/97 15:32 ;
- +1 ;;5.2;LAB SERVICE;**97,90,247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 ;
- +4 ;input trans ^DD(65.54,4,
- if $LENGTH(X)<6!($LENGTH(X)>11)!(X'?.UN)
- KILL X
- +5 IF $DATA(X)
- IF $DATA(^LRE("C",X))
- SET W=X(1)+50000
- FOR Y=0:0
- if '$DATA(X)
- QUIT
- SET Y=$ORDER(^LRE("C",X,Y))
- if 'Y
- QUIT
- if '$DATA(^LRE(Y,0))
- KILL ^LRE("C",X,Y)
- IF $DATA(^LRE("C",X,Y))
- DO I
- +6 if '$DATA(X)
- QUIT
- IF $DATA(^LRD(65,"B",X))!($DATA(^LRD(65,"C",X)))
- WRITE $CHAR(7),!?15,"INVENTORY FILE HAS AN ENTRY WITH SAME ID ! "
- DO O
- +7 QUIT
- I FOR Z=0:0
- SET Z=$ORDER(^LRE("C",X,Y,Z))
- if 'Z
- QUIT
- IF Z<W
- WRITE !,$CHAR(7),X," assigned to ",$PIECE(^LRE(Y,0),U)
- KILL X
- QUIT
- +1 QUIT
- +2 ;
- F if X=""
- QUIT
- SET X=$PIECE($PIECE(B,X_":",2),";")
- QUIT
- S ;sets C-xref in FILE 65
- +1 SET Y=^LRD(65,DA,0)
- SET S=$PIECE(Y,U,2)
- SET C=$PIECE(Y,U,4)
- SET A=$PIECE(Y,U)
- IF C
- IF S]""
- SET Y=$ORDER(^LAB(66,C,"SU","B",S,0))
- if Y
- SET Y=$LENGTH($PIECE(^LAB(66,C,"SU",Y,0),U,10))
- if Y
- SET ^LRD(65,"C",$EXTRACT(A,Y+1,$LENGTH(A)),DA)=""
- +2 QUIT
- K ;Kill C-xref in FILE 65
- +1 SET LR("DEAD")=0
- +2 SET A=""
- FOR
- SET A=$ORDER(^LRD(65,"C",A))
- if A=""!(LR("DEAD"))
- QUIT
- IF $DATA(^LRD(65,"C",A,DA))
- KILL ^LRD(65,"C",A,DA)
- SET LR("DEAD")=1
- +3 KILL LR("DEAD")
- +4 QUIT
- KK SET Y=^LRD(65,DA,0)
- SET S=$PIECE(Y,U,2)
- SET C=$PIECE(Y,U,4)
- SET A=LR(65,.01)
- +1 IF C
- IF S]""
- Begin DoDot:1
- +2 SET Y=$ORDER(^LAB(66,C,"SU","B",S,0))
- +3 if Y
- SET Y=$LENGTH($PIECE(^LAB(66,C,"SU",Y,0),U,10))
- End DoDot:1
- +4 IF Y
- KILL ^LRD(65,"C",$EXTRACT(A,Y+1,$LENGTH(A)),DA)
- QUIT
- +5 QUIT
- S1 IF 1
- +1 QUIT
- K1 ;Kill AG x-ref DD(65,4.1,1,
- +1 SET A=^LRD(65,DA,6)
- SET Z=$PIECE(A,U,4)
- SET A=+A
- +2 IF A
- IF Z
- Begin DoDot:1
- +3 SET B=+$PIECE($GET(^LR(A,1.6,Z,0)),U,11)
- +4 KILL ^LRD(65,"AB",$EXTRACT(X,1,30),DA)
- +5 KILL ^LRD(65,DA,4),^(5),^(6),^(7),^LR(A,1.6,Z),^LR("AB",A,B,Z)
- +6 IF $DATA(^LR(A,1.6,0))
- SET A=^(0)
- SET Z=$ORDER(^(0))
- SET ^(0)=$PIECE(A,U,1,2)_U_Z_U_$SELECT('Z:Z,1:($PIECE(A,U,4)-1))
- End DoDot:1
- +7 QUIT
- A ;Makes change to ^LRD(65,"AP" & date unit assigned if necessary
- +1 IF X'="C"
- IF X'="IG"
- KILL ^LRD(65,"AP",DA(1),DA(2))
- SET $PIECE(^LRD(65,DA(2),2,DA(1),0),U,2)=""
- QUIT
- +2 SET ^LRD(65,"AP",DA(1),DA(2))=""
- SET X(1)=$PIECE(^LRD(65,DA(2),2,DA(1),0),U,2)
- IF 'X(1)
- SET LR=X
- SET X="N"
- SET %DT="T"
- DO ^%DT
- SET X=LR
- SET $PIECE(^LRD(65,DA(2),2,DA(1),0),U,2)=Y
- +3 QUIT
- EN ;
- +1 FOR A=0:0
- SET A=$ORDER(^LRD(65,"B",X,A))
- if 'A
- QUIT
- IF $DATA(LR)#2
- IF $DATA(^LRD(65,A,0))
- IF $PIECE(^(0),U,4)=LR
- WRITE $CHAR(7),!,"UNIT IN INVENTORY - EDIT TRANSFUSION DATA THERE !"
- KILL X
- QUIT
- +2 ;input transform ^DD(63.017,.03,0)
- QUIT
- EN1 ;
- +1 SET (DIC,DIE)="^LAB(61.3,"
- +2 SET X=0
- FOR X(1)=0:0
- SET X=$ORDER(^LAB(61.3,"B","D",X))
- if 'X
- QUIT
- IF X
- IF ^(X)=""
- QUIT
- +3 IF X
- SET (LRB,DA)=X
- SET DR="2///50710"
- DO ^DIE
- GOTO END
- +4 SET X="D"
- SET DIC(0)="ML"
- SET DLAYGO=61
- DO ^DIC
- KILL DIC
- +5 SET DA=+Y
- SET DR="2///50710"
- DO ^DIE
- SET LRB=$ORDER(^LAB(61.3,"C",50710,0))
- +6 KILL DLAYGO
- +7 ;
- EN2 ;called by TRANSFUSION entry in EXECUTE CODE file
- +1 SET X="N"
- SET %DT="T"
- DO ^%DT
- SET X1=Y
- SET X2=-3
- DO C^%DTC
- SET X=9999999-X
- +2 SET A=0
- FOR B=1:1
- SET A=$ORDER(^LR(LRDFN,"BB",A))
- if 'A!(A>X)
- QUIT
- if B=1
- WRITE $CHAR(7),!,"Specimen(s) received within past 72 hrs:"
- SET Z=^(A,0)
- SET Y=+Z
- DO DT^LRU
- WRITE !,Y,?18,$PIECE(Z,U,6)
- +3 QUIT
- EN3 ;delete user print list for transfusion & hematology data
- +1 DO OUT
- +2 SET X="BLOOD BANK"
- DO ^LRUTL
- +3 if 'LRAA
- GOTO OUT
- +4 IF '$DATA(^LRO(69.2,LRAA,7,0))
- WRITE $CHAR(7),!!,"There are no user lists."
- GOTO OUT
- +5 SET (DIC,DIE)="^LRO(69.2,LRAA,7,"
- SET DIC(0)="AEQM"
- DO ^DIC
- KILL DIC
- if Y<1
- GOTO OUT
- +6 SET DA=+Y
- SET DA(1)=LRAA
- SET DR=.01
- DO ^DIE
- GOTO EN3
- D SET X=$ORDER(^LAB(69.9,1,8,"B","DONOR",0))
- IF 'X
- WRITE $CHAR(7),"Must define blood bank site parameters using option:",!?3,"Edit blood bank site parameters [LRBLSSP] under the Supervisor menu"
- KILL X
- QUIT
- +1 SET X=^LAB(69.9,1,8,X,0)
- SET LRH(2)=$PIECE(X,U,3)
- SET LRH(3)=$PIECE(X,U,4)
- IF LRH(2)=""!(LRH(3)="")
- WRITE $CHAR(7),!!,"Must enter second and third defaults for DONOR using:",!?3,"Edit blood bank site parameters [LRBLSSP] under the Supervisor menu"
- KILL X
- QUIT
- +2 SET LRH(17)=+$PIECE(X,U,6)
- SET LRH(20)=+$PIECE(X,U,7)
- QUIT
- OUT DO V^LRU
- QUIT
- O ;enter old donor unit (CAUTION: This unit is in inventory)
- +1 IF '$DATA(LRD("U"))
- KILL X
- QUIT
- +2 WRITE !!,"Do you still want to enter this unit in the donor file "
- SET %=2
- DO YN^LRU
- IF %=1
- WRITE !,"Ok, done."
- QUIT
- +3 KILL X
- QUIT
- P ;from DD(63.01, input transforms for fields 6.1 to 6.4
- +1 if '$DATA(^LR(LRDFN,"BB",LRI,A,X))&('$DATA(^LR(LRDFN,B,X)))
- QUIT
- +2 WRITE !!,$PIECE(^LAB(61.3,X,0),U)," antigen cannot be present & absent.",!
- KILL ^LR(LRDFN,"BB",LRI,C,X)
- SET X=^LR(LRDFN,"BB",LRI,C,0)
- SET X(1)=$ORDER(^(0))
- SET ^(0)=$PIECE(X,U,1,2)_U_X(1)_U_$SELECT('X(1):"",1:($PIECE(X,U,4)-1))
- KILL X
- QUIT
- B ;
- +1 SET X="T"
- SET %DT=""
- DO ^%DT
- DO D^LRU
- SET LRH=Y
- +2 SET %DT="AETX"
- SET %DT(0)="-N"
- SET %DT("A")="Start with Date TODAY// "
- DO ^%DT
- KILL %DT
- IF X=""
- SET Y=DT
- WRITE LRH
- +3 if Y<1
- QUIT
- SET LRSDT=Y
- +4 SET %DT="AETX"
- SET %DT("A")="Go to Date TODAY// "
- DO ^%DT
- KILL %DT
- IF X=""
- SET Y=DT
- WRITE LRH
- +5 if Y<1
- QUIT
- SET LRLDT=Y
- IF LRSDT>LRLDT
- SET X=LRSDT
- SET LRSDT=LRLDT
- SET LRLDT=X
- +6 SET Y=LRSDT
- DO D^LRU
- SET LRSTR=Y
- SET Y=LRLDT
- DO D^LRU
- SET LRLST=Y
- KILL LRH
- QUIT
- DT WRITE !
- SET %DT("A")="Date/time work completed: NOW// "
- SET %DT="AEQTX"
- SET %DT(0)="-N"
- DO ^%DT
- KILL %DT
- IF X[U!(Y>1&(Y'["."))
- WRITE $CHAR(7),!?35,"Not allowed, enter date and time.",!?35,"Future times not allowed."
- GOTO DT
- +1 IF Y<1
- SET X="N"
- SET %DT="EQTX"
- DO ^%DT
- KILL %DT
- +2 SET LRK=Y
- WRITE !
- QUIT
- +3 ;
- END KILL DIC,DIE,DR,DA
- QUIT