LRBLJR ; IHS/DIR/AAB - RELEASE FROM XMATCH 6/20/96 12:11 ;
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END I LRCAPA S X="UNIT RELEASE" D X^LRUWK G:'$D(X) END
ASK K DIC,LRZ W ! D ^LRDPA G:LRDFN=-1 END K A,LRV D R G ASK
;
R W ! S LRX=0 F A=1:1 S LRX=$O(^LRD(65,"AP",LRDFN,LRX)) Q:'LRX I $D(^LRD(65,LRX,0)) S W=^(0),M=$P(^(2,LRDFN,0),"^",2),A(A)=LRX D:A=1 H D W
I A=1 W $C(7),!!,"No units crossmatched for ",LRP Q
D DT^LRBLU I A=2 S LRV=1 D RES G OUT:$D(LRZ),REL
SEL W !,"Select units (1-",A-1,") for release: " R X:DTIME Q:X=""!(X[U) I X["?" W !,"Enter numbers from 1 to ",A-1,!,"For 2 or more selections separate each with a ',' (ex. 1,3,4)",!,"Enter 'ALL' for all units." G SEL
G:X="ALL" ALL
I X?.E1CA.E!($L(X)>200) W $C(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed" G SEL
I '+X W $C(7),!,"START with a NUMBER !!",! G SEL
S LRQ=X D RES G:$D(LRZ) OUT F LRA=0:0 S LRV=+LRQ,LRQ=$E(LRQ,$L(LRV)+2,$L(LRQ)) D:LRV REL Q:'$L(LRQ)
Q
REL I '$D(A(LRV)) W !!,$C(7),"Selection ",LRV," doesn't exist.",! Q
I P(LRV)]"",P(LRV)'["BLOOD BANK" W $C(7),!!,$P(^LRD(65,A(LRV),0),"^")," not returned to BLOOD BANK. Cannot release." Q
S A=1,LRX=A(LRV) I '$D(LRV(2)) S W=^LRD(65,LRX,0) W ! D W W !?25,"Ok to release " S %=1 D YN^LRU Q:%'=1
K ^LRD(65,"AP",LRDFN,LRX) S X=$P(^LRD(65,LRX,2,LRDFN,0),"^",3),^(0)=LRDFN
I X S X=$O(^LRD(65,LRX,2,LRDFN,1,"B",X,0)) I X,$D(^LRD(65,LRX,2,LRDFN,1,X,0)) S $P(^(0),"^",10)=LRV(1)
W:'$D(LRV(2)) !?3,"Released",! D:LRCAPA ^LRBLW Q
;
ALL S LRV(2)=1 D RES G:$D(LRZ) OUT F LRV=0:0 S LRV=$O(A(LRV)) Q:'LRV D REL
W !!?3,"All valid releases completed." Q
;
W D:A#20=0 M S P=+$O(^LRD(65,LRX,3,0)) S P(A)=$S($D(^(P,0)):$P(^(0),"^",4),1:"")
W A,")",?3,$P(W,"^"),?15,$J($P(W,"^",7),2),?18,$P(W,"^",8),?22,$E($P(^LAB(66,$P(W,"^",4),0),"^"),1,20),?43 S T=$P(W,"^",6) D T^LRBLJX W T,?55 I M S T=M D T^LRBLJX W T
W ?67,$E(P(A),1,12),! Q
H W !,"#",?3,"Unit ID",?15,"ABO/Rh",?22,"Component",?43,"Exp date",?55,"Xmatch date",?67,"Location",! Q
M R "Press RETURN",X:DTIME W $C(13),$J("",15),$C(13) Q
RES R !,"Reason for release: ",X:DTIME I X=""!(X[U) S:X[U LRZ=1 K X G SET
I X="TRANSFUSED" W $C(7)," Not allowed, try again." G RES
I X["?"!($E(X)=" ") D G RES
. N HLP D FIELD^DID(65.02,.1,"","HELP-PROMPT","HLP")
. S HLP=HLP("HELP-PROMPT") W !,HLP
. S L(1)="B" D Q^LRUB
N CHK S CHK=$$GET1^DID(65.02,.1,"","INPUT TRANSFORM") X CHK I '$D(X) W $C(7),!,"Reason not valid, try again " S %=1 D YN^LRU G:%=1 RES
SET S LRV(1)=$S($D(X):X,1:"No release reason given") Q
OUT W $C(7)," Unit(s) not released." Q
END D V^LRU Q
LRBLJR ; IHS/DIR/AAB - RELEASE FROM XMATCH 6/20/96 12:11 ;
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+3 DO END
SET X="BLOOD BANK"
DO ^LRUTL
IF Y=-1
GOTO END
IF LRCAPA
SET X="UNIT RELEASE"
DO X^LRUWK
IF '$DATA(X)
GOTO END
ASK KILL DIC,LRZ
WRITE !
DO ^LRDPA
IF LRDFN=-1
GOTO END
KILL A,LRV
DO R
GOTO ASK
+1 ;
R WRITE !
SET LRX=0
FOR A=1:1
SET LRX=$ORDER(^LRD(65,"AP",LRDFN,LRX))
IF 'LRX
QUIT
IF $DATA(^LRD(65,LRX,0))
SET W=^(0)
SET M=$PIECE(^(2,LRDFN,0),"^",2)
SET A(A)=LRX
IF A=1
DO H
DO W
+1 IF A=1
WRITE $CHAR(7),!!,"No units crossmatched for ",LRP
QUIT
+2 DO DT^LRBLU
IF A=2
SET LRV=1
DO RES
IF $DATA(LRZ)
GOTO OUT
GOTO REL
SEL WRITE !,"Select units (1-",A-1,") for release: "
READ X:DTIME
IF X=""!(X[U)
QUIT
IF X["?"
WRITE !,"Enter numbers from 1 to ",A-1,!,"For 2 or more selections separate each with a ',' (ex. 1,3,4)",!,"Enter 'ALL' for all units."
GOTO SEL
+1 IF X="ALL"
GOTO ALL
+2 IF X?.E1CA.E!($LENGTH(X)>200)
WRITE $CHAR(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed"
GOTO SEL
+3 IF '+X
WRITE $CHAR(7),!,"START with a NUMBER !!",!
GOTO SEL
+4 SET LRQ=X
DO RES
IF $DATA(LRZ)
GOTO OUT
FOR LRA=0:0
SET LRV=+LRQ
SET LRQ=$EXTRACT(LRQ,$LENGTH(LRV)+2,$LENGTH(LRQ))
IF LRV
DO REL
IF '$LENGTH(LRQ)
QUIT
+5 QUIT
REL IF '$DATA(A(LRV))
WRITE !!,$CHAR(7),"Selection ",LRV," doesn't exist.",!
QUIT
+1 IF P(LRV)]""
IF P(LRV)'["BLOOD BANK"
WRITE $CHAR(7),!!,$PIECE(^LRD(65,A(LRV),0),"^")," not returned to BLOOD BANK. Cannot release."
QUIT
+2 SET A=1
SET LRX=A(LRV)
IF '$DATA(LRV(2))
SET W=^LRD(65,LRX,0)
WRITE !
DO W
WRITE !?25,"Ok to release "
SET %=1
DO YN^LRU
IF %'=1
QUIT
+3 KILL ^LRD(65,"AP",LRDFN,LRX)
SET X=$PIECE(^LRD(65,LRX,2,LRDFN,0),"^",3)
SET ^(0)=LRDFN
+4 IF X
SET X=$ORDER(^LRD(65,LRX,2,LRDFN,1,"B",X,0))
IF X
IF $DATA(^LRD(65,LRX,2,LRDFN,1,X,0))
SET $PIECE(^(0),"^",10)=LRV(1)
+5 IF '$DATA(LRV(2))
WRITE !?3,"Released",!
IF LRCAPA
DO ^LRBLW
QUIT
+6 ;
ALL SET LRV(2)=1
DO RES
IF $DATA(LRZ)
GOTO OUT
FOR LRV=0:0
SET LRV=$ORDER(A(LRV))
IF 'LRV
QUIT
DO REL
+1 WRITE !!?3,"All valid releases completed."
QUIT
+2 ;
W IF A#20=0
DO M
SET P=+$ORDER(^LRD(65,LRX,3,0))
SET P(A)=$SELECT($DATA(^(P,0)):$PIECE(^(0),"^",4),1:"")
+1 WRITE A,")",?3,$PIECE(W,"^"),?15,$JUSTIFY($PIECE(W,"^",7),2),?18,$PIECE(W,"^",8),?22,$EXTRACT($PIECE(^LAB(66,$PIECE(W,"^",4),0),"^"),1,20),?43
SET T=$PIECE(W,"^",6)
DO T^LRBLJX
WRITE T,?55
IF M
SET T=M
DO T^LRBLJX
WRITE T
+2 WRITE ?67,$EXTRACT(P(A),1,12),!
QUIT
H WRITE !,"#",?3,"Unit ID",?15,"ABO/Rh",?22,"Component",?43,"Exp date",?55,"Xmatch date",?67,"Location",!
QUIT
M READ "Press RETURN",X:DTIME
WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
QUIT
RES READ !,"Reason for release: ",X:DTIME
IF X=""!(X[U)
IF X[U
SET LRZ=1
KILL X
GOTO SET
+1 IF X="TRANSFUSED"
WRITE $CHAR(7)," Not allowed, try again."
GOTO RES
+2 IF X["?"!($EXTRACT(X)=" ")
Begin DoDot:1
+3 NEW HLP
DO FIELD^DID(65.02,.1,"","HELP-PROMPT","HLP")
+4 SET HLP=HLP("HELP-PROMPT")
WRITE !,HLP
+5 SET L(1)="B"
DO Q^LRUB
End DoDot:1
GOTO RES
+6 NEW CHK
SET CHK=$$GET1^DID(65.02,.1,"","INPUT TRANSFORM")
XECUTE CHK
IF '$DATA(X)
WRITE $CHAR(7),!,"Reason not valid, try again "
SET %=1
DO YN^LRU
IF %=1
GOTO RES
SET SET LRV(1)=$SELECT($DATA(X):X,1:"No release reason given")
QUIT
OUT WRITE $CHAR(7)," Unit(s) not released."
QUIT
END DO V^LRU
QUIT
