- LRBLJM ; IHS/DIR/AAB - EDIT POOLED UNIT 9/26/97 13:01 ; [ 04/29/98 10:43 AM ]
- ;;5.2;LR;**1003**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**90**;Sep 27, 1994
- D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END D BAR^LRBLB
- ASK R !!,"Select POOLED UNIT: ",X:DTIME G:X=""!(X[U) END I X?7N.N,X'["?",LR,$E(X,1,$L(LR(2)))=LR(2) D ^LRBLBU G:'$D(X) ASK
- I '$O(^LRD(65,"B",X,0)) W $C(7)," Must enter a specific unit" G ASK
- D REST,K^LRU
- I $D(LRLOCK) L -^LRD(65,LRLOCK)
- K ^TMP($J),LRV,LRP,DA,LRLOCK G ASK
- REST S LR("Q")=0,DIC="^LRD(65,",DIC(0)="EFQMZ",DIC("S")="I $P($G(^LAB(66,+$P(^(0),U,4),0)),U,27)"
- D ^DIC K DIC Q:Y<1 S LRP=+Y,LRW=Y(0),LRA=$P(^LAB(66,$P(Y(0),U,4),0),U,26) D L Q:LRL
- I $P(^LRD(65,LRP,0),U,16)'=DUZ(2) W $C(7),!!,"You can only edit Pooled Units from your own division.",! G ASK
- I '$O(^LRD(65,LRP,9,0)) W $C(7),!,"No units in pool." Q
- W !?5,"Units in pool: " S E=0 F LRB=0:0 S LRB=$O(^LRD(65,LRP,9,LRB)) Q:'LRB!(LR("Q")) S X=^(LRB,0),Y=$P(X,"^",2),LRZ=+X D:Y]"" W
- Q:'$D(^TMP($J))!(LR("Q"))
- S S DIR(0)="S^A:Add unit to pool;R:Remove unit from pool;D:Delete the pool" D ^DIR
- G:$D(DIRUT) END
- D @(Y_"^LRBLJM1")
- Q
- ;
- W S LRV=0 F B=0:0 S B=$O(^LRD(65,"B",Y,B)) Q:'B S W=^LRD(65,B,0),W(4)=$P(^LAB(66,LRZ,0),U) I $P(W,U,4)=LRZ S LRV=1,E=E+1,^TMP($J,E)=LRB_U_B_U_$P(W,U)_U_W(4) W !?7,$P(W,U),?25,W(4) D:E#21=0 M^LRU Q:LR("Q")
- I 'LRV S LR("Q")=1 D F
- Q
- F W $C(7),!!?7,Y,?25,$P(^LAB(66,LRZ,0),U)," not correct" S DIC="^LAB(66,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,26)=LRA",DIC("A")="Select CORRECT COMPONENT: " D ^DIC K DIC Q:Y<1 S $P(^LRD(65,LRP,9,LRB,0),U)=+Y
- S DA(1)=LRP,DA=LRB,X=+Y,O=LRZ,Z="65.091,.01" D EN^LRUD
- Q
- L ;
- S LRL=0
- I $D(LRLOCK)#2 L -^LRD(65,LRLOCK)
- S LRLOCK=LRP L +^LRD(65,LRP):1
- I '$T W !,$C(7),"ANOTHER TERMINAL IS EDITING ",$P(^LRD(65,LRP,0),U) S LRL=1
- Q
- ;
- END D V^LRU Q
- LRBLJM ; IHS/DIR/AAB - EDIT POOLED UNIT 9/26/97 13:01 ; [ 04/29/98 10:43 AM ]
- +1 ;;5.2;LR;**1003**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**90**;Sep 27, 1994
- +3 DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- IF Y=-1
- GOTO END
- DO BAR^LRBLB
- ASK READ !!,"Select POOLED UNIT: ",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 ^LRBLBU
- IF '$DATA(X)
- GOTO ASK
- +1 IF '$ORDER(^LRD(65,"B",X,0))
- WRITE $CHAR(7)," Must enter a specific unit"
- GOTO ASK
- +2 DO REST
- DO K^LRU
- +3 IF $DATA(LRLOCK)
- LOCK -^LRD(65,LRLOCK)
- +4 KILL ^TMP($JOB),LRV,LRP,DA,LRLOCK
- GOTO ASK
- REST SET LR("Q")=0
- SET DIC="^LRD(65,"
- SET DIC(0)="EFQMZ"
- SET DIC("S")="I $P($G(^LAB(66,+$P(^(0),U,4),0)),U,27)"
- +1 DO ^DIC
- KILL DIC
- IF Y<1
- QUIT
- SET LRP=+Y
- SET LRW=Y(0)
- SET LRA=$PIECE(^LAB(66,$PIECE(Y(0),U,4),0),U,26)
- DO L
- IF LRL
- QUIT
- +2 IF $PIECE(^LRD(65,LRP,0),U,16)'=DUZ(2)
- WRITE $CHAR(7),!!,"You can only edit Pooled Units from your own division.",!
- GOTO ASK
- +3 IF '$ORDER(^LRD(65,LRP,9,0))
- WRITE $CHAR(7),!,"No units in pool."
- QUIT
- +4 WRITE !?5,"Units in pool: "
- SET E=0
- FOR LRB=0:0
- SET LRB=$ORDER(^LRD(65,LRP,9,LRB))
- IF 'LRB!(LR("Q"))
- QUIT
- SET X=^(LRB,0)
- SET Y=$PIECE(X,"^",2)
- SET LRZ=+X
- IF Y]""
- DO W
- +5 IF '$DATA(^TMP($JOB))!(LR("Q"))
- QUIT
- S SET DIR(0)="S^A:Add unit to pool;R:Remove unit from pool;D:Delete the pool"
- DO ^DIR
- +1 IF $DATA(DIRUT)
- GOTO END
- +2 DO @(Y_"^LRBLJM1")
- +3 QUIT
- +4 ;
- W SET LRV=0
- FOR B=0:0
- SET B=$ORDER(^LRD(65,"B",Y,B))
- IF 'B
- QUIT
- SET W=^LRD(65,B,0)
- SET W(4)=$PIECE(^LAB(66,LRZ,0),U)
- IF $PIECE(W,U,4)=LRZ
- SET LRV=1
- SET E=E+1
- SET ^TMP($JOB,E)=LRB_U_B_U_$PIECE(W,U)_U_W(4)
- WRITE !?7,$PIECE(W,U),?25,W(4)
- IF E#21=0
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 IF 'LRV
- SET LR("Q")=1
- DO F
- +2 QUIT
- F WRITE $CHAR(7),!!?7,Y,?25,$PIECE(^LAB(66,LRZ,0),U)," not correct"
- SET DIC="^LAB(66,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $P(^(0),U,26)=LRA"
- SET DIC("A")="Select CORRECT COMPONENT: "
- DO ^DIC
- KILL DIC
- IF Y<1
- QUIT
- SET $PIECE(^LRD(65,LRP,9,LRB,0),U)=+Y
- +1 SET DA(1)=LRP
- SET DA=LRB
- SET X=+Y
- SET O=LRZ
- SET Z="65.091,.01"
- DO EN^LRUD
- +2 QUIT
- L ;
- +1 SET LRL=0
- +2 IF $DATA(LRLOCK)#2
- LOCK -^LRD(65,LRLOCK)
- +3 SET LRLOCK=LRP
- LOCK +^LRD(65,LRP):1
- +4 IF '$TEST
- WRITE !,$CHAR(7),"ANOTHER TERMINAL IS EDITING ",$PIECE(^LRD(65,LRP,0),U)
- SET LRL=1
- +5 QUIT
- +6 ;
- END DO V^LRU
- QUIT
