LRBLDC ;AVAMC/REG/CYM - DONOR COMPONENT PREP ;7/3/96 11:58 ;
;;5.2;LAB SERVICE;**72,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 W @IOF,?20,"Collection disposition/component preparation",!
I LRCAPA S X="DONOR COMPONENT PREPARATION",X("NOCODES")=1 D X^LRUWK G:'$D(X) END
D BAR^LRBLB
I R !!,"Select BLOOD DONOR: ",X:DTIME G:X=""!(X[U) END I X?7N.N,X'["?",LR,$E(X,1,$L(LR(2)))=LR(2) D EN^LRBLBU G:'$D(X) I
S DIC="^LRE(",DIC(0)="EQM",D="B^C^"_$S("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D") D MIX^DIC1 K DIC G I:Y<1 S LRQ=+Y D REST,^LRBLDC1 K LR("CK"),DIC,DIE,DR,DA,DQ G I
REST S LRI=$O(^LRE(LRQ,5,0)) I 'LRI W $C(7),!!,"No collection date for this patient",! Q
I $P(^LRE(LRQ,5,LRI,0),U,4)="" W $C(7),!,"NO UNIT ID ENTERED !" Q
I $P(^LRE(LRQ,5,LRI,0),U,14) W $C(7),!,"Not allowed, data entered via old blood donor records option." Q
S X=^LRE(LRQ,0),LRP=$P(X,U),W(5)=$P(X,U,5),W(6)=$P(X,U,6)
S Z=^LRE(LRQ,5,LRI,0),Y=$S($D(^(2)):$P(^(2),"^",2),1:+Z) D D^LRU W !!,"Donor: ",LRP," ABO: ",W(5)," Rh: ",W(6),!,"Donation date/time: ",Y,?50,"Unit ID: ",$P(Z,"^",4)
S C=$P(Z,"^",2) I C=""!(C="N") W $C(7),!,"Sorry no collection indicated",! Q
I $P(Z,"^",10)=2 W $C(7),!,"Collection discarded",! Q
N LRDATA S LRDATA=^LRE(LRQ,5,LRI,2),LR(65.54)=$P(LRDATA,U,3)
S DIE="^LRE(",DA=LRQ,DR="[LRBLDC]" D CK^LRU Q:$D(LR("CK")) W ! D ^DIE D FRE^LRU
Q:'$D(LRB) K LRF,DIC,DIE,DR,DA F A=0:0 S A=$O(^LRE(LRQ,5,LRI,66,A)) Q:'A W !?5,$P(^LAB(66,A,0),"^") S LRF(A)=""
S:'$D(^LRE(LRQ,5,LRI,66,0)) ^(0)="^65.66PAI^^"
C S (DIC,DIE)="^LRE(LRQ,5,LRI,66,",LRZ=0 F X=0:0 S X=$O(^LRE(LRQ,5,LRI,66,X)) Q:'X S LRZ=$P(^LAB(66,X,0),"^",19) Q:LRZ
R !!,"Select BLOOD COMPONENT: ",X:DTIME G:X=""!(X[U) W I LR,$E(X,1,$L(LR(2)))=LR(2),$A(X)<58,$A(X)>47 D P^LRBLB G:'$D(X) C
W ! S DA(2)=LRQ,DA(1)=LRI,LRB(4)=$P(^LRE(LRQ,5,LRI,66,0),"^",4),DIC(0)=$S(LRB(4)<LRB(1):"EQLM",1:"EQM") S:(LRB(4)<LRB(1)) DLAYGO=65 D ^DIC K DIC,DLAYGO G:Y<1 C S DA=+Y,LRA=^LAB(66,DA,0) I $P(Y,"^",3),LRZ,$P(LRA,"^",19) D KILL G C
S X=^LRE(LRQ,5,LRI,66,DA,0),O=$P(X,U,3),M=$P(X,U,4),M(5)=$P(X,U,5),LRB(6)=9999999,LRB(5)="",LRB(7)=$P(LRA,"^",17),LRA=$P(LRA,"^",10)
I LRB(7) S LRB(3)=$P(LRB(2),".",2),X1=$P(LRB(2),"."),X2=$P(LRB(7),".") D C^%DTC S (Y,LRB(6))=X D D^LRU S LRB(5)=Y I LRB(7)["." S Z=LRB(6)_"."_LRB(3),X="."_$P(LRB(7),".",2),Z(0)=$P(X*24*60,".") D EN
S DR=".01;.03//^S X=LRB(9);I $L(O),O'=X S Z=.03 D S^LRBLDC;S:'X Y=.01;.04//^S X=LRB(5);D:X>LRB(6) X^LRBLDC;I $L(M),M'=X S O=M,Z=.04 D S^LRBLDC;.05//^S X=LRA;I $L(M(5)),M(5)'=X S O=M(5),Z=.05 D S^LRBLDC"
D ^DIE G C
W F W=0:0 S W=$O(LRF(W)) Q:'W I '$D(^LRE(LRQ,5,LRI,66,W)) S Z="65.66,.01",(O,DA)=W,DA(1)=LRI,DA(2)=LRQ,X="deleted" D EN^LRUD
Q
KILL W !,$C(7),"Cannot select more than one red blood cell product.",!,"Selection ",$P(^LAB(66,DA,0),U)," canceled !",! L +^LRE(LRQ,5,LRI,66)
K ^LRE(LRQ,5,LRI,66,DA),^LRE(LRQ,5,LRI,66,"B",DA) S X=^LRE(LRQ,5,LRI,66,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_$S(X(1)="":"",1:($P(X,"^",4)-1)) L -^LRE(LRQ,5,LRI,66) Q
;
END D V^LRU Q
;
S S Z="65.66,"_Z D EN^LRUD Q
;
X W $C(7),!?4,"Expiration date exceeds allowable limit !",! S X=^LRE(LRQ,5,LRI,66,DA,0),^(0)=$P(X,"^",1,3)_"^^"_$P(X,"^",5,99),Y=.04 Q
EN ;from LRBLJLG1
D H^LRUT S W(1)=Z(3)+Z(0) D C^LRUT S %H=$E(W,1,5),Z=$E(W,6,9),Z(1)=Z\60,Z(2)=Z#60 D YMD^%DTC S (LRB(6),Y)=X_"."_$E("00",1,2-$L(Z(1)))_Z(1)_$E("00",1,2-$L(Z(2)))_Z(2) D D^LRU S LRB(5)=$E(Y,1,12)_"@"_$E(Y,15,19) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDC 3563 printed Oct 16, 2024@18:11:10 Page 2
LRBLDC ;AVAMC/REG/CYM - DONOR COMPONENT PREP ;7/3/96 11:58 ;
+1 ;;5.2;LAB SERVICE;**72,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
WRITE @IOF,?20,"Collection disposition/component preparation",!
+4 IF LRCAPA
SET X="DONOR COMPONENT PREPARATION"
SET X("NOCODES")=1
DO X^LRUWK
if '$DATA(X)
GOTO END
+5 DO BAR^LRBLB
I READ !!,"Select BLOOD DONOR: ",X:DTIME
if X=""!(X[U)
GOTO END
IF X?7N.N
IF X'["?"
IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
DO EN^LRBLBU
if '$DATA(X)
GOTO I
+1 SET DIC="^LRE("
SET DIC(0)="EQM"
SET D="B^C^"_$SELECT("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D")
DO MIX^DIC1
KILL DIC
if Y<1
GOTO I
SET LRQ=+Y
DO REST
DO ^LRBLDC1
KILL LR("CK"),DIC,DIE,DR,DA,DQ
GOTO I
REST SET LRI=$ORDER(^LRE(LRQ,5,0))
IF 'LRI
WRITE $CHAR(7),!!,"No collection date for this patient",!
QUIT
+1 IF $PIECE(^LRE(LRQ,5,LRI,0),U,4)=""
WRITE $CHAR(7),!,"NO UNIT ID ENTERED !"
QUIT
+2 IF $PIECE(^LRE(LRQ,5,LRI,0),U,14)
WRITE $CHAR(7),!,"Not allowed, data entered via old blood donor records option."
QUIT
+3 SET X=^LRE(LRQ,0)
SET LRP=$PIECE(X,U)
SET W(5)=$PIECE(X,U,5)
SET W(6)=$PIECE(X,U,6)
+4 SET Z=^LRE(LRQ,5,LRI,0)
SET Y=$SELECT($DATA(^(2)):$PIECE(^(2),"^",2),1:+Z)
DO D^LRU
WRITE !!,"Donor: ",LRP," ABO: ",W(5)," Rh: ",W(6),!,"Donation date/time: ",Y,?50,"Unit ID: ",$PIECE(Z,"^",4)
+5 SET C=$PIECE(Z,"^",2)
IF C=""!(C="N")
WRITE $CHAR(7),!,"Sorry no collection indicated",!
QUIT
+6 IF $PIECE(Z,"^",10)=2
WRITE $CHAR(7),!,"Collection discarded",!
QUIT
+7 NEW LRDATA
SET LRDATA=^LRE(LRQ,5,LRI,2)
SET LR(65.54)=$PIECE(LRDATA,U,3)
+8 SET DIE="^LRE("
SET DA=LRQ
SET DR="[LRBLDC]"
DO CK^LRU
if $DATA(LR("CK"))
QUIT
WRITE !
DO ^DIE
DO FRE^LRU
+9 if '$DATA(LRB)
QUIT
KILL LRF,DIC,DIE,DR,DA
FOR A=0:0
SET A=$ORDER(^LRE(LRQ,5,LRI,66,A))
if 'A
QUIT
WRITE !?5,$PIECE(^LAB(66,A,0),"^")
SET LRF(A)=""
+10 if '$DATA(^LRE(LRQ,5,LRI,66,0))
SET ^(0)="^65.66PAI^^"
C SET (DIC,DIE)="^LRE(LRQ,5,LRI,66,"
SET LRZ=0
FOR X=0:0
SET X=$ORDER(^LRE(LRQ,5,LRI,66,X))
if 'X
QUIT
SET LRZ=$PIECE(^LAB(66,X,0),"^",19)
if LRZ
QUIT
+1 READ !!,"Select BLOOD COMPONENT: ",X:DTIME
if X=""!(X[U)
GOTO W
IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
IF $ASCII(X)<58
IF $ASCII(X)>47
DO P^LRBLB
if '$DATA(X)
GOTO C
+2 WRITE !
SET DA(2)=LRQ
SET DA(1)=LRI
SET LRB(4)=$PIECE(^LRE(LRQ,5,LRI,66,0),"^",4)
SET DIC(0)=$SELECT(LRB(4)<LRB(1):"EQLM",1:"EQM")
if (LRB(4)<LRB(1))
SET DLAYGO=65
DO ^DIC
KILL DIC,DLAYGO
if Y<1
GOTO C
SET DA=+Y
SET LRA=^LAB(66,DA,0)
IF $PIECE(Y,"^",3)
IF LRZ
IF $PIECE(LRA,"^",19)
DO KILL
GOTO C
+3 SET X=^LRE(LRQ,5,LRI,66,DA,0)
SET O=$PIECE(X,U,3)
SET M=$PIECE(X,U,4)
SET M(5)=$PIECE(X,U,5)
SET LRB(6)=9999999
SET LRB(5)=""
SET LRB(7)=$PIECE(LRA,"^",17)
SET LRA=$PIECE(LRA,"^",10)
+4 IF LRB(7)
SET LRB(3)=$PIECE(LRB(2),".",2)
SET X1=$PIECE(LRB(2),".")
SET X2=$PIECE(LRB(7),".")
DO C^%DTC
SET (Y,LRB(6))=X
DO D^LRU
SET LRB(5)=Y
IF LRB(7)["."
SET Z=LRB(6)_"."_LRB(3)
SET X="."_$PIECE(LRB(7),".",2)
SET Z(0)=$PIECE(X*24*60,".")
DO EN
+5 SET DR=".01;.03//^S X=LRB(9);I $L(O),O'=X S Z=.03 D S^LRBLDC;S:'X Y=.01;.04//^S X=LRB(5);D:X>LRB(6) X^LRBLDC;I $L(M),M'=X S O=M,Z=.04 D S^LRBLDC;.05//^S X=LRA;I $L(M(5)),M(5)'=X S O=M(5),Z=.05 D S^LRBLDC"
+6 DO ^DIE
GOTO C
W FOR W=0:0
SET W=$ORDER(LRF(W))
if 'W
QUIT
IF '$DATA(^LRE(LRQ,5,LRI,66,W))
SET Z="65.66,.01"
SET (O,DA)=W
SET DA(1)=LRI
SET DA(2)=LRQ
SET X="deleted"
DO EN^LRUD
+1 QUIT
KILL WRITE !,$CHAR(7),"Cannot select more than one red blood cell product.",!,"Selection ",$PIECE(^LAB(66,DA,0),U)," canceled !",!
LOCK +^LRE(LRQ,5,LRI,66)
+1 KILL ^LRE(LRQ,5,LRI,66,DA),^LRE(LRQ,5,LRI,66,"B",DA)
SET X=^LRE(LRQ,5,LRI,66,0)
SET X(1)=$ORDER(^(0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_$SELECT(X(1)="":"",1:($PIECE(X,"^",4)-1))
LOCK -^LRE(LRQ,5,LRI,66)
QUIT
+2 ;
END DO V^LRU
QUIT
+1 ;
S SET Z="65.66,"_Z
DO EN^LRUD
QUIT
+1 ;
X WRITE $CHAR(7),!?4,"Expiration date exceeds allowable limit !",!
SET X=^LRE(LRQ,5,LRI,66,DA,0)
SET ^(0)=$PIECE(X,"^",1,3)_"^^"_$PIECE(X,"^",5,99)
SET Y=.04
QUIT
EN ;from LRBLJLG1
+1 DO H^LRUT
SET W(1)=Z(3)+Z(0)
DO C^LRUT
SET %H=$EXTRACT(W,1,5)
SET Z=$EXTRACT(W,6,9)
SET Z(1)=Z\60
SET Z(2)=Z#60
DO YMD^%DTC
SET (LRB(6),Y)=X_"."_$EXTRACT("00",1,2-$LENGTH(Z(1)))_Z(1)_$EXTRACT("00",1,2-$LENGTH(Z(2)))_Z(2)
DO D^LRU
SET LRB(5)=$EXTRACT(Y,1,12)_"@"_$EXTRACT(Y,15,19)
QUIT
