LRBLDRR1 ;AVAMC/REG/CYM - LABEL-RELEASE COMPONENTS COND'T ;11/5/97 09:28 ;
;;5.2;LAB SERVICE;**72,90,97,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
A W !!,"Select COMPONENT by number (",B," choice",$S(B=1:"",1:"s"),"): " R X:DTIME I X[U!(X="") D FRE Q
I X'?1N.N!(X<1)!(X>B) W $C(7),!?5,"Enter a number up to ",B G A
W " ",$P(F(X),U,4) I '$L($P(F(X),"^",5))!('$L($P(F(X),"^",6))) W $C(7),!,"No Date/time Stored &/or Expiration date entered." D FRE Q
S C=$P(F(X),"^",7),C(9)=$P(F(X),"^",8)
I $P(F(X),U,9) W $C(7),!,$S($P(F(X),U,9)=2:"Discarded",1:"Quarantine") Q:'$D(^XUSEC("LRBLSUPER",DUZ)) W !,"Do you want to delete DISPOSITION " S %=2 D YN^LRU G:%=1 EN^LRBLDRR2 D FRE Q
I $P(F(X),U,3)]"" W !,"Component already released to inventory" D FRE Q
S Y(1)=$P(F(X),U,2),Y(1)=$S(Y(1)="":"",Y(1):Y(1),1:+$P(Y(1),"(",2))
I Y(1)="" W !,"OK to label component " S %=1 D YN^LRU D:%<1 FRE Q:%<1 D:%=1 L Q:'LR&(%=1) I %=2 W !,"QUARANTINE or DISCARD component " S %=2 D YN^LRU D:%=1 ^LRBLDRR2 D FRE Q
S X=0 F A=12,13,14,16,18,19 S A(1)=$P(LRB(A),":"_LRJ(A)_";") I $E(A(1),$L(A(1)))=1 S X=1 Q
I X=0 F A=17,20 I $G(LRH(A)) S A(1)=$P(LRB(A),":"_LRJ(A)_";") I $E(A(1),$L(A(1)))=1 S X=1 Q
I X S LRQ("X")=1 I LRQ("S")'="A" W !!?15,$C(7),"Component should not be released- Unit quarantined.",! S $P(^LRE(LRQ,5,LRI,0),"^",10)=1 D ^LRBLDRR2 D FRE Q
S X=0 F A=12,13,14,16,18,19 I LRJ(A)=""!(LRJ(A)="NOT DONE") S X=1 Q
I X=0 F A=17,20 I $G(LRH(A)),LRJ(A)=""!(LRJ(A)="NOT DONE") S X=1 Q
I X W $C(7),!!,"Testing not completed. OK to continue " S %=2 D YN^LRU D:%=2 FRE Q:%=2 S LRQ("X")=1
I 'LR,DUZ=Y(1) W !,$C(7),"Since you labeled component someone else must release to inventory" D FRE Q
S E=$P(^LRE(LRQ,5,LRI,66,C,0),"^",4) I 'E W $C(7),!,"No expiration date entered for component" D FRE Q
X S LRABO="" K X R !?14,"ABO/Rh LABEL: ",X:DTIME Q:X=""!(X[U) I LR,$E(X,1,$L(LR(2)))=LR(2) D A^LRBLB I '$D(X) W !,$C(7),"No such ABO/Rh bar code",! G X
I LRABO="" D T^LRBLB G:'$D(X) X
S X=LRABO_" "_LRRH I X'=V(12) W $C(7),!!,"ABO/Rh label does NOT match ABO/Rh of unit",! G X
S X=^LRE(LRQ,5,LRI,0) I $P(X,"^",11)="A",$P(X,"^",12)="" W $C(7),!,"Cannot release autologous unit without assigning unit to a patient." D FRE Q
W !,"OK to release component " S %=1 D YN^LRU D:%<1 FRE Q:%<1 G:%=2 ^LRBLDRR2
I $D(^LRD(65,"AI",C,LRG)) W !,"Component in inventory" D FRE Q
S X="N",%DT="T" D ^%DT L +^LRD(65,0):5 I '$T W $C(7),!!,"I can't do this now... Someone else has this record. Try again later...",!! Q
S LRX=$P(^LRD(65,0),U,3) F B=0:0 S LRX=LRX+1 Q:'$D(^LRD(65,LRX))
N NODE,VOL
S NODE=$G(^LRE(LRQ,5,LRI,66,C,0)) S VOL=$P(NODE,U,5)
S LRK=Y,X=^LRD(65,0),^(0)=$P(X,U,1,2)_U_LRX_U_($P(X,U,4)+1),^LRD(65,LRX,0)=LRG_"^SELF^00^"_C_U_Y_U_E_U_V(10)_U_V(11)_"^^^"_VOL_"^^^^^"_DUZ(2) L -^LRD(65,0) S:LRV]"" $P(^(0),U,15)=LRV S:LRQ("X") ^LRD(65,LRX,8)="^1^"
S ^LRD(65,"D",DUZ(2),LRX)="",^LRD(65,"B",LRG,LRX)="",^LRD(65,"AI",C,LRG,E,LRX)="",^LRD(65,"A",Y,LRX)="",^LRD(65,"AE",C,E,LRX)=""
I LRQ("S")]"","DA"[LRQ("S") S ^LRD(65,LRX,8)=LRQ("D")_"^"_LRQ("X")_"^"_LRQ("S"),^LRD(65,"AU",LRQ("D"),LRX)=""
S X=$P(^LAB(69.9,1,0),"^",18)+1 I $L(LRG)>4,X>1 S ^LRD(65,"C",$E(LRG,X,$L(LRG)),LRX)=""
S X=^LRE(LRQ,5,LRI,66,C,0),^(0)=$P(X,U,1)_U_Y_U_$P(X,U,3)_U_E_U_$P(X,U,5)_U_$P(X,U,6)_U_DUZ_U_0
I LRA S ^LRD(65,LRX,10)=$S($D(^LRE(LRQ,5,LRI,10)):$P(^LRE(LRQ,5,LRI,10),"^",1,3)_"^"_1,1:""),^LRD(65,LRX,11)=$S($D(^LRE(LRQ,5,LRI,11)):$P(^LRE(LRQ,5,LRI,11),"^",1,3)_"^"_1,1:"")
D:C(9)=1 B I LRCAPA S LRT=+LRW("LG") F A=0:0 S A=$O(LRW("LG",A)) Q:'A S LRT(A)=""
D:LRCAPA ^LRBLW K LRT Q
B L +^LRD(65,LRX,60):5 I '$T W $C(7),!,"I cannot ADD the Antigen typings to the Inventory file. Someone else is editing this record...",!!,"Use the Inventory-Unit Phenotyping option to enter typing results ",!! G B1
S A=0 F B=0:1 S A=$O(^LRE(LRQ,1.1,A)) Q:'A S ^LRD(65,LRX,60,A,0)=A
I B S ^LRD(65,LRX,60,0)="^65.04PA^"_B_"^"_B
L -^LRD(65,LRX,60)
B1 L +^LRD(65,LRX,70):5 I '$T W $C(7),!,"I cannot DELETE the Antigen typings from the Inventory file. Someone else is editing this record...",!!,"Use the Inventory-Unit Phenotyping option to enter typing results",!! G B2
S A=0 F B=0:1 S A=$O(^LRE(LRQ,1.2,A)) Q:'A S ^LRD(65,LRX,70,A,0)=A
I B S ^LRD(65,LRX,70,0)="^65.05PA^"_B_"^"_B
L -^LRD(65,LRX,70)
B2 L +^LRD(65,LRX,80):5 I '$T W $C(7),!,"I cannot ADD the HLA Antigen typings to the Inventory file. Someone else is editing this record...",!!,"Use the Inventory-Unit Phenotyping option to enter typing results ",!! G B3
S A=0 F B=0:1 S A=$O(^LRE(LRQ,1.3,A)) Q:'A S ^LRD(65,LRX,80,A,0)=A
I B S ^LRD(65,LRX,80,0)="^65.08PA^"_B_"^"_B
L -^LRD(65,LRX,80)
B3 L +^LRD(65,LRX,90):5 I '$T W $C(7),!,"I cannot DELETE the HLA Antigen typings from the Inventory file. Someone else is editing this record...",!!,"Use the Inventory-Unit Phenotyping option to enter typing results ",!! G F
S A=0 F B=0:1 S A=$O(^LRE(LRQ,1.4,A)) Q:'A S ^LRD(65,LRX,90,A,0)=A
I B S ^LRD(65,LRX,90,0)="^65.09PA^"_B_"^"_B
L -^LRD(65,LRX,90)
F D:'LRA EN Q
L S $P(^LRE(LRQ,5,LRI,66,$P(F(X),"^",7),0),"^",6)=DUZ I $P(F(X),"^",10) S Y="RR" D:LRCAPA SET^LRBLWD S %=1
D FRE Q
EN ;from LRBLJD,LRBLPED2
L +^LRO(69.2,LRAA,6):5 I '$T W $C(7),!!,"I cannot add this unit to the ABO/Rh Testing Worksheet",!!,"Please be sure to add it manually when requesting the worksheet.",!! Q
S:'$D(^LRO(69.2,LRAA,6,0)) ^(0)="^69.26A^^" S Y=^(0) Q:$D(^(LRX)) S ^LRO(69.2,LRAA,6,0)=$P(Y,"^",1,2)_"^"_LRX_"^"_($P(Y,"^",4)+1),^(LRX,0)=LRX L -^LRO(69.2,LRAA,6)
Q
FRE L -^LRE(LRQ,5,LRI) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDRR1 5629 printed Oct 16, 2024@18:11:37 Page 2
LRBLDRR1 ;AVAMC/REG/CYM - LABEL-RELEASE COMPONENTS COND'T ;11/5/97 09:28 ;
+1 ;;5.2;LAB SERVICE;**72,90,97,247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
A WRITE !!,"Select COMPONENT by number (",B," choice",$SELECT(B=1:"",1:"s"),"): "
READ X:DTIME
IF X[U!(X="")
DO FRE
QUIT
+1 IF X'?1N.N!(X<1)!(X>B)
WRITE $CHAR(7),!?5,"Enter a number up to ",B
GOTO A
+2 WRITE " ",$PIECE(F(X),U,4)
IF '$LENGTH($PIECE(F(X),"^",5))!('$LENGTH($PIECE(F(X),"^",6)))
WRITE $CHAR(7),!,"No Date/time Stored &/or Expiration date entered."
DO FRE
QUIT
+3 SET C=$PIECE(F(X),"^",7)
SET C(9)=$PIECE(F(X),"^",8)
+4 IF $PIECE(F(X),U,9)
WRITE $CHAR(7),!,$SELECT($PIECE(F(X),U,9)=2:"Discarded",1:"Quarantine")
if '$DATA(^XUSEC("LRBLSUPER",DUZ))
QUIT
WRITE !,"Do you want to delete DISPOSITION "
SET %=2
DO YN^LRU
if %=1
GOTO EN^LRBLDRR2
DO FRE
QUIT
+5 IF $PIECE(F(X),U,3)]""
WRITE !,"Component already released to inventory"
DO FRE
QUIT
+6 SET Y(1)=$PIECE(F(X),U,2)
SET Y(1)=$SELECT(Y(1)="":"",Y(1):Y(1),1:+$PIECE(Y(1),"(",2))
+7 IF Y(1)=""
WRITE !,"OK to label component "
SET %=1
DO YN^LRU
if %<1
DO FRE
if %<1
QUIT
if %=1
DO L
if 'LR&(%=1)
QUIT
IF %=2
WRITE !,"QUARANTINE or DISCARD component "
SET %=2
DO YN^LRU
if %=1
DO ^LRBLDRR2
DO FRE
QUIT
+8 SET X=0
FOR A=12,13,14,16,18,19
SET A(1)=$PIECE(LRB(A),":"_LRJ(A)_";")
IF $EXTRACT(A(1),$LENGTH(A(1)))=1
SET X=1
QUIT
+9 IF X=0
FOR A=17,20
IF $GET(LRH(A))
SET A(1)=$PIECE(LRB(A),":"_LRJ(A)_";")
IF $EXTRACT(A(1),$LENGTH(A(1)))=1
SET X=1
QUIT
+10 IF X
SET LRQ("X")=1
IF LRQ("S")'="A"
WRITE !!?15,$CHAR(7),"Component should not be released- Unit quarantined.",!
SET $PIECE(^LRE(LRQ,5,LRI,0),"^",10)=1
DO ^LRBLDRR2
DO FRE
QUIT
+11 SET X=0
FOR A=12,13,14,16,18,19
IF LRJ(A)=""!(LRJ(A)="NOT DONE")
SET X=1
QUIT
+12 IF X=0
FOR A=17,20
IF $GET(LRH(A))
IF LRJ(A)=""!(LRJ(A)="NOT DONE")
SET X=1
QUIT
+13 IF X
WRITE $CHAR(7),!!,"Testing not completed. OK to continue "
SET %=2
DO YN^LRU
if %=2
DO FRE
if %=2
QUIT
SET LRQ("X")=1
+14 IF 'LR
IF DUZ=Y(1)
WRITE !,$CHAR(7),"Since you labeled component someone else must release to inventory"
DO FRE
QUIT
+15 SET E=$PIECE(^LRE(LRQ,5,LRI,66,C,0),"^",4)
IF 'E
WRITE $CHAR(7),!,"No expiration date entered for component"
DO FRE
QUIT
X SET LRABO=""
KILL X
READ !?14,"ABO/Rh LABEL: ",X:DTIME
if X=""!(X[U)
QUIT
IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
DO A^LRBLB
IF '$DATA(X)
WRITE !,$CHAR(7),"No such ABO/Rh bar code",!
GOTO X
+1 IF LRABO=""
DO T^LRBLB
if '$DATA(X)
GOTO X
+2 SET X=LRABO_" "_LRRH
IF X'=V(12)
WRITE $CHAR(7),!!,"ABO/Rh label does NOT match ABO/Rh of unit",!
GOTO X
+3 SET X=^LRE(LRQ,5,LRI,0)
IF $PIECE(X,"^",11)="A"
IF $PIECE(X,"^",12)=""
WRITE $CHAR(7),!,"Cannot release autologous unit without assigning unit to a patient."
DO FRE
QUIT
+4 WRITE !,"OK to release component "
SET %=1
DO YN^LRU
if %<1
DO FRE
if %<1
QUIT
if %=2
GOTO ^LRBLDRR2
+5 IF $DATA(^LRD(65,"AI",C,LRG))
WRITE !,"Component in inventory"
DO FRE
QUIT
+6 SET X="N"
SET %DT="T"
DO ^%DT
LOCK +^LRD(65,0):5
IF '$TEST
WRITE $CHAR(7),!!,"I can't do this now... Someone else has this record. Try again later...",!!
QUIT
+7 SET LRX=$PIECE(^LRD(65,0),U,3)
FOR B=0:0
SET LRX=LRX+1
if '$DATA(^LRD(65,LRX))
QUIT
+8 NEW NODE,VOL
+9 SET NODE=$GET(^LRE(LRQ,5,LRI,66,C,0))
SET VOL=$PIECE(NODE,U,5)
+10 SET LRK=Y
SET X=^LRD(65,0)
SET ^(0)=$PIECE(X,U,1,2)_U_LRX_U_($PIECE(X,U,4)+1)
SET ^LRD(65,LRX,0)=LRG_"^SELF^00^"_C_U_Y_U_E_U_V(10)_U_V(11)_"^^^"_VOL_"^^^^^"_DUZ(2)
LOCK -^LRD(65,0)
if LRV]""
SET $PIECE(^(0),U,15)=LRV
if LRQ("X")
SET ^LRD(65,LRX,8)="^1^"
+11 SET ^LRD(65,"D",DUZ(2),LRX)=""
SET ^LRD(65,"B",LRG,LRX)=""
SET ^LRD(65,"AI",C,LRG,E,LRX)=""
SET ^LRD(65,"A",Y,LRX)=""
SET ^LRD(65,"AE",C,E,LRX)=""
+12 IF LRQ("S")]""
IF "DA"[LRQ("S")
SET ^LRD(65,LRX,8)=LRQ("D")_"^"_LRQ("X")_"^"_LRQ("S")
SET ^LRD(65,"AU",LRQ("D"),LRX)=""
+13 SET X=$PIECE(^LAB(69.9,1,0),"^",18)+1
IF $LENGTH(LRG)>4
IF X>1
SET ^LRD(65,"C",$EXTRACT(LRG,X,$LENGTH(LRG)),LRX)=""
+14 SET X=^LRE(LRQ,5,LRI,66,C,0)
SET ^(0)=$PIECE(X,U,1)_U_Y_U_$PIECE(X,U,3)_U_E_U_$PIECE(X,U,5)_U_$PIECE(X,U,6)_U_DUZ_U_0
+15 IF LRA
SET ^LRD(65,LRX,10)=$SELECT($DATA(^LRE(LRQ,5,LRI,10)):$PIECE(^LRE(LRQ,5,LRI,10),"^",1,3)_"^"_1,1:"")
SET ^LRD(65,LRX,11)=$SELECT($DATA(^LRE(LRQ,5,LRI,11)):$PIECE(^LRE(LRQ,5,LRI,11),"^",1,3)_"^"_1,1:"")
+16 if C(9)=1
DO B
IF LRCAPA
SET LRT=+LRW("LG")
FOR A=0:0
SET A=$ORDER(LRW("LG",A))
if 'A
QUIT
SET LRT(A)=""
+17 if LRCAPA
DO ^LRBLW
KILL LRT
QUIT
B LOCK +^LRD(65,LRX,60):5
IF '$TEST
WRITE $CHAR(7),!,"I cannot ADD the Antigen typings to the Inventory file. Someone else is editing this record...",!!,"Use the Inventory-Unit Phenotyping option to enter typing results ",!!
GOTO B1
+1 SET A=0
FOR B=0:1
SET A=$ORDER(^LRE(LRQ,1.1,A))
if 'A
QUIT
SET ^LRD(65,LRX,60,A,0)=A
+2 IF B
SET ^LRD(65,LRX,60,0)="^65.04PA^"_B_"^"_B
+3 LOCK -^LRD(65,LRX,60)
B1 LOCK +^LRD(65,LRX,70):5
IF '$TEST
WRITE $CHAR(7),!,"I cannot DELETE the Antigen typings from the Inventory file. Someone else is editing this record...",!!,"Use the Inventory-Unit Phenotyping option to enter typing results",!!
GOTO B2
+1 SET A=0
FOR B=0:1
SET A=$ORDER(^LRE(LRQ,1.2,A))
if 'A
QUIT
SET ^LRD(65,LRX,70,A,0)=A
+2 IF B
SET ^LRD(65,LRX,70,0)="^65.05PA^"_B_"^"_B
+3 LOCK -^LRD(65,LRX,70)
B2 LOCK +^LRD(65,LRX,80):5
IF '$TEST
WRITE $CHAR(7),!,"I cannot ADD the HLA Antigen typings to the Inventory file. Someone else is editing this record...",!!,"Use the Inventory-Unit Phenotyping option to enter typing results ",!!
GOTO B3
+1 SET A=0
FOR B=0:1
SET A=$ORDER(^LRE(LRQ,1.3,A))
if 'A
QUIT
SET ^LRD(65,LRX,80,A,0)=A
+2 IF B
SET ^LRD(65,LRX,80,0)="^65.08PA^"_B_"^"_B
+3 LOCK -^LRD(65,LRX,80)
B3 LOCK +^LRD(65,LRX,90):5
IF '$TEST
WRITE $CHAR(7),!,"I cannot DELETE the HLA Antigen typings from the Inventory file. Someone else is editing this record...",!!,"Use the Inventory-Unit Phenotyping option to enter typing results ",!!
GOTO F
+1 SET A=0
FOR B=0:1
SET A=$ORDER(^LRE(LRQ,1.4,A))
if 'A
QUIT
SET ^LRD(65,LRX,90,A,0)=A
+2 IF B
SET ^LRD(65,LRX,90,0)="^65.09PA^"_B_"^"_B
+3 LOCK -^LRD(65,LRX,90)
F if 'LRA
DO EN
QUIT
L SET $PIECE(^LRE(LRQ,5,LRI,66,$PIECE(F(X),"^",7),0),"^",6)=DUZ
IF $PIECE(F(X),"^",10)
SET Y="RR"
if LRCAPA
DO SET^LRBLWD
SET %=1
+1 DO FRE
QUIT
EN ;from LRBLJD,LRBLPED2
+1 LOCK +^LRO(69.2,LRAA,6):5
IF '$TEST
WRITE $CHAR(7),!!,"I cannot add this unit to the ABO/Rh Testing Worksheet",!!,"Please be sure to add it manually when requesting the worksheet.",!!
QUIT
+2 if '$DATA(^LRO(69.2,LRAA,6,0))
SET ^(0)="^69.26A^^"
SET Y=^(0)
if $DATA(^(LRX))
QUIT
SET ^LRO(69.2,LRAA,6,0)=$PIECE(Y,"^",1,2)_"^"_LRX_"^"_($PIECE(Y,"^",4)+1)
SET ^(LRX,0)=LRX
LOCK -^LRO(69.2,LRAA,6)
+3 QUIT
FRE LOCK -^LRE(LRQ,5,LRI)
QUIT
