LRBLJD ;AVAMC/REG/CYM - BB UNIT DISPOSITION ;7/25/96 11:53 ; 12/18/00 2:06pm
;;5.2;LAB SERVICE;**25,72,78,247,267,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
;
; References to ^DD(65, supported by DBIA3261
;
Q D END S LR("M")=1,LRN="",X="BLOOD BANK" D ^LRUTL G:Y=-1 END S X=$P(^DD(65,4.1,0),U,3),LR(3)="" F Y=1:1 S Z=$P($P(X,";",Y),":",2) Q:Z="" I $A(Z)'=84 S LRB(Y)=Z
W !?15,"Division: ",LRAA(4)
I LRCAPA S X="UNIT MODIFICATION",X("NOCODES")=1 D X^LRUWK G:'$D(X) END K X S LRW("MO")=LRT S X="UNIT LOG-IN/SEND-OUT" D X^LRUWK G:'$D(X) END S LRW("S")=LRT F A=0:0 S A=$O(LRT(A)) Q:'A S LRW("S",A)=""
K LRT D BAR^LRBLB
ASK S X="N",%DT="T" D ^%DT S LRF=Y K %DT W !! S X=$$READ^LRBLB("Select UNIT ID FOR DISPOSITION: ") G:X=""!(X[U) END
I LR,$E(X,1,$L(LR(2)))=LR(2) D
.D ^LRBLBU
E W $$STRIP^LRBLB(.X) ; Strip off data identifiers just in case
G:'$D(X) ASK
D REST,K^LRU K ^TMP($J),DA,LR("CK"),LR("C"),LR("%5"),LR("%4"),LR("%3"),LR("%2"),LR("%"),LRO,LRM,LRV,LRE,LRP,LRJ,LRT G ASK
REST S (DIC,DIE)="^LRD(65,",DIC(0)="EFQMZ",DIC("S")="I $P(^(0),U,16)=DUZ(2),$S('$D(^(4)):1,$P(^(4),U,2):0,$P(^(4),U)="""":1,1:0)" D ^DIC K DIC Q:Y<1
S DA=+Y,LRV(10)=$P(Y(0),"^",10),LRV(4)=+$P(Y(0),"^",4),LRV(26)=$P(^LAB(66,LRV(4),0),U,26),LRV(15)=$P(Y(0),"^",15) D EN^LRBLJDA Q:$D(LR("%"))
D CK^LRU Q:$D(LR("CK")) S DR="[LRBLID]" D ^DIE D FRE^LRU S LRX=DA K DIC,DIE,DR,DA,D S DA=LRX I $D(Y) D K Q
F A=0:0 S A=$O(^LRD(65,DA,2,A)) Q:'A I $D(^LR(A,1.8,LRV(4),1,DA,0)) K ^(0) L +^LR(A,1.8,LRV(4),1,0) S X=^LR(A,1.8,LRV(4),1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1) L -^LR(A,1.8,LRV(4),1,0)
D:$D(LR("%2")) EN1^LRBLJDA Q:'$D(LRE(1)) D:"RS"[LRE(1)&LRCAPA RS^LRBLW Q:LRE(1)'="MO" S LRJ=$P($G(^LRD(65,LRX,8)),"^",2) S:LRCAPA LRT=LRW("MO")
S LRV(3)=$P(^LAB(66,LRE(4),0),"^",10),DIE="^LRD(65,",DA=LRX,DR=".11//^S X=LRV(3);S LRM=X" D ^DIE I $D(Y) D K Q
M S DIC="^LAB(66,LRE(4),3,",DIC(0)="AEQMZ" D ^DIC K DIC I Y<1 W !!,"Nothing selected " D K Q
S LRV=+Y,LRV(2)=$P(Y(0),"^",2),X=^LAB(66,LRV,0),LRN=$P(X,"^",28),LRV(1)=$P(X,"^"),LRV(6)=$P(X,"^",6),LRV(6)=$S("DP"[LRV(6):LRV(6),1:""),LRD=$P(X,"^",18),LRJ(1)=$P(X,"^",25)
I LRV(1)["PLASMA REMOVED" D PV^LRBLJDA I '$D(Z) D K Q
I LRJ,LRJ(1)'=1 W $C(7),!!,"Unit has positive screening tests and component selected is not autologous.",! G M
S (LRO(9),LRO(1))=$P(X,"^",11),LRV(11)="" D:LRO(1) F^LRBLJDM
S LRE=^LRD(65,LRX,0),(LRE(6),Y)=$P(LRE,"^",6) S:LRE(6)'["." LRE(6)=LRE(6)_".9999" D D^LRU S LRE(3)=Y,LRE(69)=LRE(6)
I LRE(6)<LRF W $C(7),!!,"UNIT EXPIRED " S Y=$P(LRE,U,6) D D^LRU W Y," STILL WANT TO MODIFY " S %=2 D YN^LRU I %'=1 D K Q
I LRO(1)="" S Y=$P(LRE,"^",6) D DA^LRU S LRO(1)=Y
D @$S(LRV(6)="D":"D^LRBLJDM",LRV(2):"^LRBLJDM",LRV(6)="P":"^LRBLJD1",1:"S^LRBLJDM") Q
K ;from LRBLJD1, LRBLJDM, [LRBLID] edit template file #65
W $C(7),!,"Answer all prompts (no NULL responses) DISPOSITION DELETED",!!
X:$D(^DD(65,4.1,1,1,2)) ^(2) X:$D(^DD(65,4.1,1,2,2)) ^(2) X:$D(^DD(65,4.1,1,3,2)) ^(2) S X=$S($D(^LRD(65,DA,4)):$P(^(4),"^",2),1:"") K:X ^LRD(65,"AB",X,DA) K ^LRD(65,DA,4),^(5) Q
;
END D V^LRU Q
;
R R !,"DISPOSITION: ",LRE(1):DTIME S:LRE(1)="" LRE(1)=U Q:LRE(1)[U
F X=0:0 S X=$O(LRB(X)) Q:'X I $E(LRB(X),1,$L(LRE(1)))=LRE(1) W $E(LRB(X),$L(LRE(1))+1,$L(LRB(X))) S LRE(1)=LRB(X) G OUT
W !!,"Select from:"
F X=0:0 S X=$O(LRB(X)) Q:'X W !?3,LRB(X)
W ! G R
OUT I $D(^LRD(65,DA,8)),$P(^(8),"^",2)'=0,LRE(1)="SEND ELSEWHERE"!(LRE(1)="SALVAGED") S X=$P(^(8),"^",2) D C
Q
C W $C(7),!,$S(X:"POSITIVE",1:"INCOMPLETE")," SCREENING TESTS." I LRE(1)="SEND ELSEWHERE" W " WANT TO CONTINUE " S %=2 D YN^LRU S:%'=1 LRE(1)=U Q
W " SALVAGE NOT ALLOWED." S LRE(1)=U Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJD 3752 printed Sep 23, 2025@19:46:45 Page 2
LRBLJD ;AVAMC/REG/CYM - BB UNIT DISPOSITION ;7/25/96 11:53 ; 12/18/00 2:06pm
+1 ;;5.2;LAB SERVICE;**25,72,78,247,267,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 ;
+4 ; References to ^DD(65, supported by DBIA3261
+5 ;
+6 QUIT
DO END
SET LR("M")=1
SET LRN=""
SET X="BLOOD BANK"
DO ^LRUTL
if Y=-1
GOTO END
SET X=$PIECE(^DD(65,4.1,0),U,3)
SET LR(3)=""
FOR Y=1:1
SET Z=$PIECE($PIECE(X,";",Y),":",2)
if Z=""
QUIT
IF $ASCII(Z)'=84
SET LRB(Y)=Z
+7 WRITE !?15,"Division: ",LRAA(4)
+8 IF LRCAPA
SET X="UNIT MODIFICATION"
SET X("NOCODES")=1
DO X^LRUWK
if '$DATA(X)
GOTO END
KILL X
SET LRW("MO")=LRT
SET X="UNIT LOG-IN/SEND-OUT"
DO X^LRUWK
if '$DATA(X)
GOTO END
SET LRW("S")=LRT
FOR A=0:0
SET A=$ORDER(LRT(A))
if 'A
QUIT
SET LRW("S",A)=""
+9 KILL LRT
DO BAR^LRBLB
ASK SET X="N"
SET %DT="T"
DO ^%DT
SET LRF=Y
KILL %DT
WRITE !!
SET X=$$READ^LRBLB("Select UNIT ID FOR DISPOSITION: ")
if X=""!(X[U)
GOTO END
+1 IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
Begin DoDot:1
+2 DO ^LRBLBU
End DoDot:1
+3 ; Strip off data identifiers just in case
IF '$TEST
WRITE $$STRIP^LRBLB(.X)
+4 if '$DATA(X)
GOTO ASK
+5 DO REST
DO K^LRU
KILL ^TMP($JOB),DA,LR("CK"),LR("C"),LR("%5"),LR("%4"),LR("%3"),LR("%2"),LR("%"),LRO,LRM,LRV,LRE,LRP,LRJ,LRT
GOTO ASK
REST SET (DIC,DIE)="^LRD(65,"
SET DIC(0)="EFQMZ"
SET DIC("S")="I $P(^(0),U,16)=DUZ(2),$S('$D(^(4)):1,$P(^(4),U,2):0,$P(^(4),U)="""":1,1:0)"
DO ^DIC
KILL DIC
if Y<1
QUIT
+1 SET DA=+Y
SET LRV(10)=$PIECE(Y(0),"^",10)
SET LRV(4)=+$PIECE(Y(0),"^",4)
SET LRV(26)=$PIECE(^LAB(66,LRV(4),0),U,26)
SET LRV(15)=$PIECE(Y(0),"^",15)
DO EN^LRBLJDA
if $DATA(LR("%"))
QUIT
+2 DO CK^LRU
if $DATA(LR("CK"))
QUIT
SET DR="[LRBLID]"
DO ^DIE
DO FRE^LRU
SET LRX=DA
KILL DIC,DIE,DR,DA,D
SET DA=LRX
IF $DATA(Y)
DO K
QUIT
+3 FOR A=0:0
SET A=$ORDER(^LRD(65,DA,2,A))
if 'A
QUIT
IF $DATA(^LR(A,1.8,LRV(4),1,DA,0))
KILL ^(0)
LOCK +^LR(A,1.8,LRV(4),1,0)
SET X=^LR(A,1.8,LRV(4),1,0)
SET X(1)=$ORDER(^(0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
LOCK -^LR(A,1.8,LRV(4),1,0)
+4 if $DATA(LR("%2"))
DO EN1^LRBLJDA
if '$DATA(LRE(1))
QUIT
if "RS"[LRE(1)&LRCAPA
DO RS^LRBLW
if LRE(1)'="MO"
QUIT
SET LRJ=$PIECE($GET(^LRD(65,LRX,8)),"^",2)
if LRCAPA
SET LRT=LRW("MO")
+5 SET LRV(3)=$PIECE(^LAB(66,LRE(4),0),"^",10)
SET DIE="^LRD(65,"
SET DA=LRX
SET DR=".11//^S X=LRV(3);S LRM=X"
DO ^DIE
IF $DATA(Y)
DO K
QUIT
M SET DIC="^LAB(66,LRE(4),3,"
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
IF Y<1
WRITE !!,"Nothing selected "
DO K
QUIT
+1 SET LRV=+Y
SET LRV(2)=$PIECE(Y(0),"^",2)
SET X=^LAB(66,LRV,0)
SET LRN=$PIECE(X,"^",28)
SET LRV(1)=$PIECE(X,"^")
SET LRV(6)=$PIECE(X,"^",6)
SET LRV(6)=$SELECT("DP"[LRV(6):LRV(6),1:"")
SET LRD=$PIECE(X,"^",18)
SET LRJ(1)=$PIECE(X,"^",25)
+2 IF LRV(1)["PLASMA REMOVED"
DO PV^LRBLJDA
IF '$DATA(Z)
DO K
QUIT
+3 IF LRJ
IF LRJ(1)'=1
WRITE $CHAR(7),!!,"Unit has positive screening tests and component selected is not autologous.",!
GOTO M
+4 SET (LRO(9),LRO(1))=$PIECE(X,"^",11)
SET LRV(11)=""
if LRO(1)
DO F^LRBLJDM
+5 SET LRE=^LRD(65,LRX,0)
SET (LRE(6),Y)=$PIECE(LRE,"^",6)
if LRE(6)'["."
SET LRE(6)=LRE(6)_".9999"
DO D^LRU
SET LRE(3)=Y
SET LRE(69)=LRE(6)
+6 IF LRE(6)<LRF
WRITE $CHAR(7),!!,"UNIT EXPIRED "
SET Y=$PIECE(LRE,U,6)
DO D^LRU
WRITE Y," STILL WANT TO MODIFY "
SET %=2
DO YN^LRU
IF %'=1
DO K
QUIT
+7 IF LRO(1)=""
SET Y=$PIECE(LRE,"^",6)
DO DA^LRU
SET LRO(1)=Y
+8 DO @$SELECT(LRV(6)="D":"D^LRBLJDM",LRV(2):"^LRBLJDM",LRV(6)="P":"^LRBLJD1",1:"S^LRBLJDM")
QUIT
K ;from LRBLJD1, LRBLJDM, [LRBLID] edit template file #65
+1 WRITE $CHAR(7),!,"Answer all prompts (no NULL responses) DISPOSITION DELETED",!!
+2 if $DATA(^DD(65,4.1,1,1,2))
XECUTE ^(2)
if $DATA(^DD(65,4.1,1,2,2))
XECUTE ^(2)
if $DATA(^DD(65,4.1,1,3,2))
XECUTE ^(2)
SET X=$SELECT($DATA(^LRD(65,DA,4)):$PIECE(^(4),"^",2),1:"")
if X
KILL ^LRD(65,"AB",X,DA)
KILL ^LRD(65,DA,4),^(5)
QUIT
+3 ;
END DO V^LRU
QUIT
+1 ;
R READ !,"DISPOSITION: ",LRE(1):DTIME
if LRE(1)=""
SET LRE(1)=U
if LRE(1)[U
QUIT
+1 FOR X=0:0
SET X=$ORDER(LRB(X))
if 'X
QUIT
IF $EXTRACT(LRB(X),1,$LENGTH(LRE(1)))=LRE(1)
WRITE $EXTRACT(LRB(X),$LENGTH(LRE(1))+1,$LENGTH(LRB(X)))
SET LRE(1)=LRB(X)
GOTO OUT
+2 WRITE !!,"Select from:"
+3 FOR X=0:0
SET X=$ORDER(LRB(X))
if 'X
QUIT
WRITE !?3,LRB(X)
+4 WRITE !
GOTO R
OUT IF $DATA(^LRD(65,DA,8))
IF $PIECE(^(8),"^",2)'=0
IF LRE(1)="SEND ELSEWHERE"!(LRE(1)="SALVAGED")
SET X=$PIECE(^(8),"^",2)
DO C
+1 QUIT
C WRITE $CHAR(7),!,$SELECT(X:"POSITIVE",1:"INCOMPLETE")," SCREENING TESTS."
IF LRE(1)="SEND ELSEWHERE"
WRITE " WANT TO CONTINUE "
SET %=2
DO YN^LRU
if %'=1
SET LRE(1)=U
QUIT
+1 WRITE " SALVAGE NOT ALLOWED."
SET LRE(1)=U
QUIT
