- LRBLJD1 ; IHS/DIR/AAB - POOL COMPONENTS 10/9/97 07:24 ; [ 04/29/98 10:11 AM ]
- ;;5.2;LR;**1003**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**25,90**;Sep 27, 1994
- K LRT S:$G(LRCAPA) LRT=LRW("MO")
- S LR("%5")=1,C=$P(^LAB(66,LRE(4),0),"^") F A=0:0 S A=$O(^LAB(66,LRV,9,A)) Q:'A S LRT(A)=""
- I LRCAPA,'$O(LRT(0)) W $C(7),!!,"Must enter WKLD CODES in BLOOD PRODUCT FILE (#66)",!,"for ",$P(^LAB(66,LRV,0),U)," to pool unit.",! S DA=LRX D K^LRBLJD Q
- W !?31,"Unit ID",?41,"ABO/Rh",!!,"Selection 1 (unit ID to pool): ",$P(LRE,"^"),?41,$J($P(LRE,"^",7),2),?44,$P(LRE,"^",8)
- S LRP(1)=LRX_"^"_$P(LRE,"^")_"^"_$P(LRE,"^",7)_" "_$P(LRE,"^",8)_"^"_$P(LRE,"^",6)_"^"_$P(LRE,"^",4) F N=2:1 D C Q:'$D(Y)
- I N=2 W !!,"No need to pool 1 unit",! S DA=LRX D K^LRBLJD Q
- W !!,"Pool will contain the following ",$P(^LAB(66,LRE(4),0),"^")," units:",!?3,"ID #",?22,"Expiration date"
- S A=0 F B=0:1 S A=$O(LRP(A)) Q:'A W !,$J(A,2),?3,$P(LRP(A),"^",2),?15,$P(LRP(A),"^",3),?22 S Y=$P(LRP(A),"^",4) D D^LRU W Y
- S LRM=LRM*B W !!,"ALL OK " S %=1 D YN^LRU I %'=1 D K K LRP Q
- ID R !!,"Select UNIT ID number for POOL: ",X:DTIME I X=""!(X[U) W !,$C(7),"UNITS selected were NOT pooled !",! D K Q
- F A=0:0 S A=$O(LRP(A)) Q:'A I $P(LRP(A),"^",3)["POS" S $P(LRE,"^",8)="POS" Q
- I LR,$E(X,1,$L(LR(2)))=LR(2) D ^LRBLBU
- G:'$D(X) K X $P(^DD(65,.01,0),"^",5,99) I $D(X),X["?" K X
- I '$D(X) W !!,$C(7),$S($D(^DD(65,.01,3)):^(3),1:""),! X:$D(^(4)) ^(4) G ID
- I $O(^LRD(65,"B",X,0))!($O(^LRD(65,"C",X,0))) W !,$C(7),"SORRY THAT ALREADY EXISTS",! G ID
- S LRE(1)=X,(Y,LRE(6))=LRE(69) D D^LRU S LRE(3)=Y D ^LRBLJDA S:'$D(^LRD(65,DA,9,0)) ^(0)="^65.091PAI^^" I LRCAPA
- S Z=0 F LR("C")=1:1 S Z=$O(LRP(Z)) Q:'Z S LRX=+LRP(Z),^LRD(65,DA,9,LR("C"),0)=$P(LRP(Z),"^",5)_"^"_$P(LRP(Z),"^",2)_"^"_1,^LRD(65,LRX,9,0)="^65.091PAI^1^1",^(1,0)=LRV_"^"_LRE(1)_"^"_2 D XR D:LRCAPA ^LRBLW
- S X=^LRD(65,DA,9,0),^(0)="^65.091PAI^"_(LR("C")-1)_"^"_(LR("C")-1)
- D S Q
- C W !,"Selection ",N," (Unit ID to pool): " R X:DTIME I X=""!(X[U) K Y Q
- I LR,$A(X)<58,$A(X)>47 D ^LRBLBU G:'$D(X) C
- S DIC="^LRD(65,",DIC(0)="EFQMZ",DIC("S")="I $S('$D(^(4)):1,$P(^(4),U)']"""":1,1:0)&($P(^LAB(66,$P(^(0),U,4),0),U,26)=LRV(26))" D ^DIC K DIC G:Y<1 C I '$D(^LAB(66,+$P(Y(0),U,4),3,LRV,0)) W !,"Cannot pool this unit" G C
- S LRE("P")=Y,DA=+Y,LRL=Y(0) D EN^LRBLJDA I $D(LR("%")) K LR("%") G C
- S (LRE(6),LRE(9))=$P(LRL,"^",6) S:LRE(6)'["." LRE(6)=LRE(6)_".9999" I LRE(6)<LRF W $C(7),!!,"UNIT EXPIRED " S Y=LRE(9) D D^LRU W Y," STILL WANT TO INCLUDE IN POOL " S %=2 D YN^LRU S:%=1 LR("%4")=1 G:%'=1 C
- S:LRE(6)<LRE(69) LRE(69)=LRE(6)
- S LRV(10)=LRV(10)+$P(LRL,"^",10),Y=LRE("P"),LRP(N)=+Y_"^"_$P(LRL,"^")_"^"_$P(LRL,"^",7)_" "_$P(LRL,"^",8)_"^"_$P(LRL,"^",6)_"^"_$P(LRL,"^",4),^LRD(65,+Y,4)="MO^"_LRE(2)_"^"_DUZ
- D CMV S DA=+Y K ^LRD(65,"AE",$P(LRL,"^",4),$P(LRL,"^",6),DA) X:$D(^DD(65,4.1,1,2,1)) ^(1) X:$D(^DD(65,4.1,1,1,1)) ^(1) S X=LRE(2) X:$D(^DD(65,4.2,1,1,1)) ^(1) Q
- ;
- K K X F E=0:0 S E=$O(LRP(E)) Q:'E S DA=+LRP(E) 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,3,2)) ^(2) I $D(^LRD(65,DA,4)) S X=$P(^(4),"^",2) K:X ^LRD(65,"AB",X,DA) K ^LRD(65,DA,4),^(5)
- Q
- XR F Z(1)=0:0 S Z(1)=$O(^LRD(65,LRX,2,Z(1))) Q:'Z(1) K ^LRD(65,"AP",Z(1),LRX)
- Q
- S W ! S X=0 F A=1:1 S X=$O(^TMP($J,X)) Q:'X S Y=^(X),B(A)=X W !,$J(A,2),") ",$P(Y,U),?30,$P(Y,U,2)
- I A=2 S LRDFN=$O(^TMP($J,0)) G SET
- Q:A<3 S A=A-1 W !,"To assign pool Select from (1-",A,"): " R X:DTIME Q:X=""!(X[U) I +X'=X!(X<1)!(X>A) W $C(7),!,"Select a number from 1 to ",A G S
- S Y=^TMP($J,B(X)),LRDFN=B(X)
- SET W !,"Assign ",LRE(1)," to ",$P(Y,U)," ",$P(Y,U,2)," " S %=1 D YN^LRU Q:%'=1
- S ^LRD(65,DA,2,0)="^65.01IA^"_LRDFN_"^"_1,^(LRDFN,0)=LRDFN
- S DA(1)=DA,DA=LRDFN,DIE="^LRD(65,DA(1),2,",DR=.02 D ^DIE Q
- CMV Q:LRV(15) S X=$P(LRL,"^",15),LRV(15)=$S(X="":"",X=1:1,1:LRV(15)) Q
- LRBLJD1 ; IHS/DIR/AAB - POOL COMPONENTS 10/9/97 07:24 ; [ 04/29/98 10:11 AM ]
- +1 ;;5.2;LR;**1003**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**25,90**;Sep 27, 1994
- +3 KILL LRT
- IF $GET(LRCAPA)
- SET LRT=LRW("MO")
- +4 SET LR("%5")=1
- SET C=$PIECE(^LAB(66,LRE(4),0),"^")
- FOR A=0:0
- SET A=$ORDER(^LAB(66,LRV,9,A))
- IF 'A
- QUIT
- SET LRT(A)=""
- +5 IF LRCAPA
- IF '$ORDER(LRT(0))
- WRITE $CHAR(7),!!,"Must enter WKLD CODES in BLOOD PRODUCT FILE (#66)",!,"for ",$PIECE(^LAB(66,LRV,0),U)," to pool unit.",!
- SET DA=LRX
- DO K^LRBLJD
- QUIT
- +6 WRITE !?31,"Unit ID",?41,"ABO/Rh",!!,"Selection 1 (unit ID to pool): ",$PIECE(LRE,"^"),?41,$JUSTIFY($PIECE(LRE,"^",7),2),?44,$PIECE(LRE,"^",8)
- +7 SET LRP(1)=LRX_"^"_$PIECE(LRE,"^")_"^"_$PIECE(LRE,"^",7)_" "_$PIECE(LRE,"^",8)_"^"_$PIECE(LRE,"^",6)_"^"_$PIECE(LRE,"^",4)
- FOR N=2:1
- DO C
- IF '$DATA(Y)
- QUIT
- +8 IF N=2
- WRITE !!,"No need to pool 1 unit",!
- SET DA=LRX
- DO K^LRBLJD
- QUIT
- +9 WRITE !!,"Pool will contain the following ",$PIECE(^LAB(66,LRE(4),0),"^")," units:",!?3,"ID #",?22,"Expiration date"
- +10 SET A=0
- FOR B=0:1
- SET A=$ORDER(LRP(A))
- IF 'A
- QUIT
- WRITE !,$JUSTIFY(A,2),?3,$PIECE(LRP(A),"^",2),?15,$PIECE(LRP(A),"^",3),?22
- SET Y=$PIECE(LRP(A),"^",4)
- DO D^LRU
- WRITE Y
- +11 SET LRM=LRM*B
- WRITE !!,"ALL OK "
- SET %=1
- DO YN^LRU
- IF %'=1
- DO K
- KILL LRP
- QUIT
- ID READ !!,"Select UNIT ID number for POOL: ",X:DTIME
- IF X=""!(X[U)
- WRITE !,$CHAR(7),"UNITS selected were NOT pooled !",!
- DO K
- QUIT
- +1 FOR A=0:0
- SET A=$ORDER(LRP(A))
- IF 'A
- QUIT
- IF $PIECE(LRP(A),"^",3)["POS"
- SET $PIECE(LRE,"^",8)="POS"
- QUIT
- +2 IF LR
- IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
- DO ^LRBLBU
- +3 IF '$DATA(X)
- GOTO K
- XECUTE $PIECE(^DD(65,.01,0),"^",5,99)
- IF $DATA(X)
- IF X["?"
- KILL X
- +4 IF '$DATA(X)
- WRITE !!,$CHAR(7),$SELECT($DATA(^DD(65,.01,3)):^(3),1:""),!
- IF $DATA(^(4))
- XECUTE ^(4)
- GOTO ID
- +5 IF $ORDER(^LRD(65,"B",X,0))!($ORDER(^LRD(65,"C",X,0)))
- WRITE !,$CHAR(7),"SORRY THAT ALREADY EXISTS",!
- GOTO ID
- +6 SET LRE(1)=X
- SET (Y,LRE(6))=LRE(69)
- DO D^LRU
- SET LRE(3)=Y
- DO ^LRBLJDA
- IF '$DATA(^LRD(65,DA,9,0))
- SET ^(0)="^65.091PAI^^"
- IF LRCAPA
- +7 SET Z=0
- FOR LR("C")=1:1
- SET Z=$ORDER(LRP(Z))
- IF 'Z
- QUIT
- SET LRX=+LRP(Z)
- SET ^LRD(65,DA,9,LR("C"),0)=$PIECE(LRP(Z),"^",5)_"^"_$PIECE(LRP(Z),"^",2)_"^"_1
- SET ^LRD(65,LRX,9,0)="^65.091PAI^1^1"
- SET ^(1,0)=LRV_"^"_LRE(1)_"^"_2
- DO XR
- IF LRCAPA
- DO ^LRBLW
- +8 SET X=^LRD(65,DA,9,0)
- SET ^(0)="^65.091PAI^"_(LR("C")-1)_"^"_(LR("C")-1)
- +9 DO S
- QUIT
- C WRITE !,"Selection ",N," (Unit ID to pool): "
- READ X:DTIME
- IF X=""!(X[U)
- KILL Y
- QUIT
- +1 IF LR
- IF $ASCII(X)<58
- IF $ASCII(X)>47
- DO ^LRBLBU
- IF '$DATA(X)
- GOTO C
- +2 SET DIC="^LRD(65,"
- SET DIC(0)="EFQMZ"
- SET DIC("S")="I $S('$D(^(4)):1,$P(^(4),U)']"""":1,1:0)&($P(^LAB(66,$P(^(0),U,4),0),U,26)=LRV(26))"
- DO ^DIC
- KILL DIC
- IF Y<1
- GOTO C
- IF '$DATA(^LAB(66,+$PIECE(Y(0),U,4),3,LRV,0))
- WRITE !,"Cannot pool this unit"
- GOTO C
- +3 SET LRE("P")=Y
- SET DA=+Y
- SET LRL=Y(0)
- DO EN^LRBLJDA
- IF $DATA(LR("%"))
- KILL LR("%")
- GOTO C
- +4 SET (LRE(6),LRE(9))=$PIECE(LRL,"^",6)
- IF LRE(6)'["."
- SET LRE(6)=LRE(6)_".9999"
- IF LRE(6)<LRF
- WRITE $CHAR(7),!!,"UNIT EXPIRED "
- SET Y=LRE(9)
- DO D^LRU
- WRITE Y," STILL WANT TO INCLUDE IN POOL "
- SET %=2
- DO YN^LRU
- IF %=1
- SET LR("%4")=1
- IF %'=1
- GOTO C
- +5 IF LRE(6)<LRE(69)
- SET LRE(69)=LRE(6)
- +6 SET LRV(10)=LRV(10)+$PIECE(LRL,"^",10)
- SET Y=LRE("P")
- SET LRP(N)=+Y_"^"_$PIECE(LRL,"^")_"^"_$PIECE(LRL,"^",7)_" "_$PIECE(LRL,"^",8)_"^"_$PIECE(LRL,"^",6)_"^"_$PIECE(LRL,"^",4)
- SET ^LRD(65,+Y,4)="MO^"_LRE(2)_"^"_DUZ
- +7 DO CMV
- SET DA=+Y
- KILL ^LRD(65,"AE",$PIECE(LRL,"^",4),$PIECE(LRL,"^",6),DA)
- IF $DATA(^DD(65,4.1,1,2,1))
- XECUTE ^(1)
- IF $DATA(^DD(65,4.1,1,1,1))
- XECUTE ^(1)
- SET X=LRE(2)
- IF $DATA(^DD(65,4.2,1,1,1))
- XECUTE ^(1)
- QUIT
- +8 ;
- K KILL X
- FOR E=0:0
- SET E=$ORDER(LRP(E))
- IF 'E
- QUIT
- SET DA=+LRP(E)
- 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,3,2))
- XECUTE ^(2)
- IF $DATA(^LRD(65,DA,4))
- SET X=$PIECE(^(4),"^",2)
- IF X
- KILL ^LRD(65,"AB",X,DA)
- KILL ^LRD(65,DA,4),^(5)
- +1 QUIT
- XR FOR Z(1)=0:0
- SET Z(1)=$ORDER(^LRD(65,LRX,2,Z(1)))
- IF 'Z(1)
- QUIT
- KILL ^LRD(65,"AP",Z(1),LRX)
- +1 QUIT
- S WRITE !
- SET X=0
- FOR A=1:1
- SET X=$ORDER(^TMP($JOB,X))
- IF 'X
- QUIT
- SET Y=^(X)
- SET B(A)=X
- WRITE !,$JUSTIFY(A,2),") ",$PIECE(Y,U),?30,$PIECE(Y,U,2)
- +1 IF A=2
- SET LRDFN=$ORDER(^TMP($JOB,0))
- GOTO SET
- +2 IF A<3
- QUIT
- SET A=A-1
- WRITE !,"To assign pool Select from (1-",A,"): "
- READ X:DTIME
- IF X=""!(X[U)
- QUIT
- IF +X'=X!(X<1)!(X>A)
- WRITE $CHAR(7),!,"Select a number from 1 to ",A
- GOTO S
- +3 SET Y=^TMP($JOB,B(X))
- SET LRDFN=B(X)
- SET WRITE !,"Assign ",LRE(1)," to ",$PIECE(Y,U)," ",$PIECE(Y,U,2)," "
- SET %=1
- DO YN^LRU
- IF %'=1
- QUIT
- +1 SET ^LRD(65,DA,2,0)="^65.01IA^"_LRDFN_"^"_1
- SET ^(LRDFN,0)=LRDFN
- +2 SET DA(1)=DA
- SET DA=LRDFN
- SET DIE="^LRD(65,DA(1),2,"
- SET DR=.02
- DO ^DIE
- QUIT
- CMV IF LRV(15)
- QUIT
- SET X=$PIECE(LRL,"^",15)
- SET LRV(15)=$SELECT(X="":"",X=1:1,1:LRV(15))
- QUIT
