- 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 Feb 18, 2025@23:36:59 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
