- 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 Jan 18, 2025@03:11:34 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