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 Apr 09, 2024@21:12:03 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
