LRBLJDM ; IHS/DIR/AAB - MULTIPLE COMP PREP, INVENTORY 5/21/97 14:56 ; [ 04/29/98 10:25 AM ]
;;5.2;LR;**1003**;JUN 01, 1998
;;5.2;LAB SERVICE;**90**;Sep 27, 1994
S X=^LAB(66,LRV,0),LRP(LRV)=$P(X,"^")_"^"_$P(X,"^",10)_"^"_$P(X,"^",11)_"^"_$P(X,"^",18),LRZ=$P(X,"^",19)
C S DIC="^LAB(66,LRE(4),3,",DIC(0)="AEQMZ" D ^DIC K DIC I Y>0 S (X,Y)=+Y,X=^LAB(66,X,0),LRP(Y)=$P(X,"^")_"^"_$P(X,"^",10)_"^"_$P(X,"^",11)_"^"_$P(X,"^",18) D:'$P(^LAB(66,LRE(4),3,Y,0),"^",2) ONLY D:$D(LRP(Y)) CK G C
G:'$D(LRP) OUT S S=0 W !,"You have selected the following component(s): " S X=0 F X(1)=0:1 S X=$O(LRP(X)) Q:'X W !,$P(LRP(X),"^"),?40,"vol(ml):",$J($P(LRP(X),"^",2),5) S S=S+$P(LRP(X),"^",2)
W !?48,"-----",!?34,"Total vol(ml):",$J(S,5) I S>LRM W !!,$C(7),"Total volume of components greater than unit. SELECTIONS DELETED TRY AGAIN !",!! K LRP S LRZ=0 G C
W !?5,"All OK " S %=1 D YN^LRU I %'=1 W " SELECTIONS DELETED TRY AGAIN",! K LRP G C
S LRE(1)=$P(LRE,"^"),LRV(10)=LRV(10)/X(1) I LRV(10)["." S LRV(10)=$P(LRV(10),".")_"."_$E($P(LRV(10),".",2),1,2)
F LRH=0:0 S LRH=$O(LRP(LRH)) Q:'LRH S LRV=LRH,LRV(1)=$P(LRP(LRH),"^"),LRM=$P(LRP(LRH),"^",2),LRO(1)=$P(LRP(LRH),"^",3),LRD=$P(LRP(LRH),"^",4) D:LRO(1) F D:LRO(1)="" T D S
Q
ONLY W !!,$C(7),"Component selected must be the ONLY ONE for this unit.",!," Selection ",$P(LRP(Y),"^")," canceled !",! K LRP(Y) Q
CK I LRZ,$P(X,"^",19) W $C(7),!!,"Cannot select more than one red blood cell product.",!,"Selection ",$P(LRP(Y),"^")," canceled !",! K LRP(Y) Q
S:'LRZ LRZ=$P(X,"^",19) Q
;
T S Y=$P(LRE,"^",6) D D^LRU S LRO(1)=Y Q
;
F ;from LRBLJD
S T(2)="."_$P(LRO(1),".",2)*1440,LRO(1)=$P(LRO(1),".") S X="N",%DT="T" D ^%DT S X=Y,Y=Y_"000",T(3)=$E(Y,9,10)*60+$E(Y,11,12) D H^%DTC S T(5)=T(3)+T(2),%H=%H+LRO(1)+(T(5)\1440),T(5)=T(5)#1440\1
D D^LRUT I LRO(9)<2 S T(3)=T(5)\60,T(3)=$E("00",1,2-$L(T(3)))_T(3),T(4)=T(5)#60,T(4)=$E("00",1,2-$L(T(4)))_T(4),T(4)=T(3)_T(4) S:+T(4) X=X_"."_T(4)
S Y=$P(X,"."),X=$P(X,".",2) D D^LRU S LRO(1)=$S(X:Y_"@"_X,1:Y) Q
;
S ;from LRBLJD
S LRE(1)=$P(LRE,"^")_LRV(11) S:'$D(^LRD(65,LRX,9,0)) ^(0)="^65.091PAI^^" S X=^(0),C=$P(X,"^",4)+1,^(0)=$P(X,"^",1,2)_"^"_C_"^"_C,^(C,0)=LRV_"^"_LRE(1)_"^"_2
D:C>1 SET D ^LRBLJDA Q:'LRCAPA F A=0:0 S A=$O(^LAB(66,LRV,9,A)) Q:'A S LRT(A)=""
D ^LRBLW K LRT S LRT=LRW("MO") Q
SET S C=0 F A=0:0 S A=$O(^LRD(65,LRX,9,A)) Q:'A S:$P(^(A,0),"^",3)=2 C=C+1
S $P(^LRD(65,LRX,4),"^",4)="("_C_")" Q
;
D I LRCAPA,'$O(^LAB(66,LRV,9,0)) W $C(7),!,!!,"Must enter WKLD CODES in BLOOD PRODUCT FILE (#66)",!,"for ",$P(^LAB(66,LRV,0),U)," to divide unit.",! D OUT Q
R !,"Enter number of aliquots (1-5): ",A:DTIME I A=""!(A[U) D OUT Q
S A=+A I A>5!(A<1) W !!,"Answer must be 1,2,3,4, or 5",! G D
S LR("C")=A,LRM=LRM\A,LRV(10)=LRV(10)/A S:LRV(10)["." LRV(10)=$P(LRV(10),".")_"."_$E($P(LRV(10),".",2),1,2) F B=1:1:LR("C") S LRV(11)=$C(64+B) D S
Q
;
OUT D K^LRBLJD Q
LRBLJDM ; IHS/DIR/AAB - MULTIPLE COMP PREP, INVENTORY 5/21/97 14:56 ; [ 04/29/98 10:25 AM ]
+1 ;;5.2;LR;**1003**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**90**;Sep 27, 1994
+3 SET X=^LAB(66,LRV,0)
SET LRP(LRV)=$PIECE(X,"^")_"^"_$PIECE(X,"^",10)_"^"_$PIECE(X,"^",11)_"^"_$PIECE(X,"^",18)
SET LRZ=$PIECE(X,"^",19)
C SET DIC="^LAB(66,LRE(4),3,"
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
IF Y>0
SET (X,Y)=+Y
SET X=^LAB(66,X,0)
SET LRP(Y)=$PIECE(X,"^")_"^"_$PIECE(X,"^",10)_"^"_$PIECE(X,"^",11)_"^"_$PIECE(X,"^",18)
IF '$PIECE(^LAB(66,LRE(4),3,Y,0),"^",2)
DO ONLY
IF $DATA(LRP(Y))
DO CK
GOTO C
+1 IF '$DATA(LRP)
GOTO OUT
SET S=0
WRITE !,"You have selected the following component(s): "
SET X=0
FOR X(1)=0:1
SET X=$ORDER(LRP(X))
IF 'X
QUIT
WRITE !,$PIECE(LRP(X),"^"),?40,"vol(ml):",$JUSTIFY($PIECE(LRP(X),"^",2),5)
SET S=S+$PIECE(LRP(X),"^",2)
+2 WRITE !?48,"-----",!?34,"Total vol(ml):",$JUSTIFY(S,5)
IF S>LRM
WRITE !!,$CHAR(7),"Total volume of components greater than unit. SELECTIONS DELETED TRY AGAIN !",!!
KILL LRP
SET LRZ=0
GOTO C
+3 WRITE !?5,"All OK "
SET %=1
DO YN^LRU
IF %'=1
WRITE " SELECTIONS DELETED TRY AGAIN",!
KILL LRP
GOTO C
+4 SET LRE(1)=$PIECE(LRE,"^")
SET LRV(10)=LRV(10)/X(1)
IF LRV(10)["."
SET LRV(10)=$PIECE(LRV(10),".")_"."_$EXTRACT($PIECE(LRV(10),".",2),1,2)
+5 FOR LRH=0:0
SET LRH=$ORDER(LRP(LRH))
IF 'LRH
QUIT
SET LRV=LRH
SET LRV(1)=$PIECE(LRP(LRH),"^")
SET LRM=$PIECE(LRP(LRH),"^",2)
SET LRO(1)=$PIECE(LRP(LRH),"^",3)
SET LRD=$PIECE(LRP(LRH),"^",4)
IF LRO(1)
DO F
IF LRO(1)=""
DO T
DO S
+6 QUIT
ONLY WRITE !!,$CHAR(7),"Component selected must be the ONLY ONE for this unit.",!," Selection ",$PIECE(LRP(Y),"^")," canceled !",!
KILL LRP(Y)
QUIT
CK IF LRZ
IF $PIECE(X,"^",19)
WRITE $CHAR(7),!!,"Cannot select more than one red blood cell product.",!,"Selection ",$PIECE(LRP(Y),"^")," canceled !",!
KILL LRP(Y)
QUIT
+1 IF 'LRZ
SET LRZ=$PIECE(X,"^",19)
QUIT
+2 ;
T SET Y=$PIECE(LRE,"^",6)
DO D^LRU
SET LRO(1)=Y
QUIT
+1 ;
F ;from LRBLJD
+1 SET T(2)="."_$PIECE(LRO(1),".",2)*1440
SET LRO(1)=$PIECE(LRO(1),".")
SET X="N"
SET %DT="T"
DO ^%DT
SET X=Y
SET Y=Y_"000"
SET T(3)=$EXTRACT(Y,9,10)*60+$EXTRACT(Y,11,12)
DO H^%DTC
SET T(5)=T(3)+T(2)
SET %H=%H+LRO(1)+(T(5)\1440)
SET T(5)=T(5)#1440\1
+2 DO D^LRUT
IF LRO(9)<2
SET T(3)=T(5)\60
SET T(3)=$EXTRACT("00",1,2-$LENGTH(T(3)))_T(3)
SET T(4)=T(5)#60
SET T(4)=$EXTRACT("00",1,2-$LENGTH(T(4)))_T(4)
SET T(4)=T(3)_T(4)
IF +T(4)
SET X=X_"."_T(4)
+3 SET Y=$PIECE(X,".")
SET X=$PIECE(X,".",2)
DO D^LRU
SET LRO(1)=$SELECT(X:Y_"@"_X,1:Y)
QUIT
+4 ;
S ;from LRBLJD
+1 SET LRE(1)=$PIECE(LRE,"^")_LRV(11)
IF '$DATA(^LRD(65,LRX,9,0))
SET ^(0)="^65.091PAI^^"
SET X=^(0)
SET C=$PIECE(X,"^",4)+1
SET ^(0)=$PIECE(X,"^",1,2)_"^"_C_"^"_C
SET ^(C,0)=LRV_"^"_LRE(1)_"^"_2
+2 IF C>1
DO SET
DO ^LRBLJDA
IF 'LRCAPA
QUIT
FOR A=0:0
SET A=$ORDER(^LAB(66,LRV,9,A))
IF 'A
QUIT
SET LRT(A)=""
+3 DO ^LRBLW
KILL LRT
SET LRT=LRW("MO")
QUIT
SET SET C=0
FOR A=0:0
SET A=$ORDER(^LRD(65,LRX,9,A))
IF 'A
QUIT
IF $PIECE(^(A,0),"^",3)=2
SET C=C+1
+1 SET $PIECE(^LRD(65,LRX,4),"^",4)="("_C_")"
QUIT
+2 ;
D IF LRCAPA
IF '$ORDER(^LAB(66,LRV,9,0))
WRITE $CHAR(7),!,!!,"Must enter WKLD CODES in BLOOD PRODUCT FILE (#66)",!,"for ",$PIECE(^LAB(66,LRV,0),U)," to divide unit.",!
DO OUT
QUIT
+1 READ !,"Enter number of aliquots (1-5): ",A:DTIME
IF A=""!(A[U)
DO OUT
QUIT
+2 SET A=+A
IF A>5!(A<1)
WRITE !!,"Answer must be 1,2,3,4, or 5",!
GOTO D
+3 SET LR("C")=A
SET LRM=LRM\A
SET LRV(10)=LRV(10)/A
IF LRV(10)["."
SET LRV(10)=$PIECE(LRV(10),".")_"."_$EXTRACT($PIECE(LRV(10),".",2),1,2)
FOR B=1:1:LR("C")
SET LRV(11)=$CHAR(64+B)
DO S
+4 QUIT
+5 ;
OUT DO K^LRBLJD
QUIT
