- LRBLJR ;AVAMC/REG/CYM - RELEASE FROM XMATCH ;6/20/96 12:11 ;
- ;;5.2;LAB SERVICE;**72,247,267,408**;Sep 27, 1994;Build 8
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- Q 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,"^"),?17,$J($P(W,"^",7),2),?20,$P(W,"^",8),?24,$E($P(^LAB(66,$P(W,"^",4),0),"^"),1,20),?45 S T=$P(W,"^",6) D T^LRBLJX W T,?58 I M S T=M D T^LRBLJX W T
- W ?70,$E(P(A),1,10),! Q
- H W !,"#",?3,"Unit ID",?17,"ABO/Rh",?24,"Component",?45,"Exp date",?58,"Xmatch date",?70,"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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJR 2756 printed Feb 18, 2025@23:37:18 Page 2
- LRBLJR ;AVAMC/REG/CYM - RELEASE FROM XMATCH ;6/20/96 12:11 ;
- +1 ;;5.2;LAB SERVICE;**72,247,267,408**;Sep 27, 1994;Build 8
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 QUIT
- 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,"^"),?17,$JUSTIFY($PIECE(W,"^",7),2),?20,$PIECE(W,"^",8),?24,$EXTRACT($PIECE(^LAB(66,$PIECE(W,"^",4),0),"^"),1,20),?45
- SET T=$PIECE(W,"^",6)
- DO T^LRBLJX
- WRITE T,?58
- IF M
- SET T=M
- DO T^LRBLJX
- WRITE T
- +2 WRITE ?70,$EXTRACT(P(A),1,10),!
- QUIT
- H WRITE !,"#",?3,"Unit ID",?17,"ABO/Rh",?24,"Component",?45,"Exp date",?58,"Xmatch date",?70,"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
