LRBLDRR.m

LRBLDRR ; IHS/DIR/AAB - REVIEW/RELEASE COMPONENTS 1/24/97 11:04 ; [ 02/03/1999  2:08 PM ]

 ;;5.2;LR;**1002,1003**;JUN 01, 1998

 ;;5.2;LAB SERVICE;**72,90,97**;Sep 27, 1994

 D E S LR("M")=1,X="BLOOD BANK" D ^LRUTL G:Y=-1 E D D^LRBLU G:'$D(X) E

 I LRCAPA S X="DONOR UNIT LABELING" D X^LRUWK G:'$D(X) E S Y="RR" D S^LRBLWD K LRT S X="UNIT LOG-IN/SEND-OUT" D X^LRUWK G:'$D(X) E

 S LRA=$S($D(^LAB(69.9,1,8,1,0)):$P(^(0),"^",2),1:0),Y="LG" D:LRCAPA S^LRBLWD

 W !!?20,"Review-label-release components",!!?20,LRAA(4),! D BAR^LRBLB I LR W !!?15,"STANDARD UNIT ID LABELING " S %=1 D YN^LRU G:%<1 E S LR(3)=$S(%=1:"",1:1)

 F A=1,6.1,10:1:16,18,19 D

 . D FIELD^DID(65.54,A,"","POINTER","LRB") S LRB(A)=LRB("POINTER")

 . D FIELD^DID(65.54,A,"","LABEL","LRN") S LRN(A)=LRN("LABEL")

 F A=17,20 I $G(LRH(A)) D

 . D FIELD^DID(65.54,A,"","POINTER","LRB") S LRB(A)=LRB("POINTER")

 . D FIELD^DID(65.54,A,"","LABEL","LRN") S LRN(A)=LRN("LABEL")

P R !!,"Select UNIT FOR LABEL/RELEASE: ",X:DTIME I LR D U^LRBLB

 W ! S DIC="^LRE(",DIC(0)="FQMZ",D="C^B" D MIX^DIC1 K DIC G E:X[U!(X=""),P:Y<1 S LRQ(5)=$P(Y(0),"^",5),LRQ(6)=$P(Y(0),"^",6),LRQ("X")=0

 I X["," D ASK G:Y<1 P D REST G P

 S LRQ=+Y,LRI=$O(^LRE("C",X,LRQ,0)) G:'LRI P L +^LRE(LRQ,5,LRI):5 I '$T W !,$C(7),"Someone else is editing this entry! " G P

 S LRG=$P(^LRE(LRQ,5,LRI,0),"^",4) D REST G P

 ;

S S F=^LAB(66,A,0),Y=$P(X,"^",3) D D^LRU S S=Y,Y=$P(X,"^",4) D D^LRU

 S F(B)=$P(X,"^",2)_"^"_$P(X,"^",6)_"^"_$P(X,"^",7)_"^"_$E($P(F,"^"),1,21)_"^"_S_"^"_Y_"^"_A_"^"_$P(F,"^",9)_"^"_$P(X,"^",8)_"^"_$P(F,"^",19) Q

 ;

REST S LRV=$P(^LRE(LRQ,0),"^",15),X=^(5,LRI,0),LRQ("S")=$P(X,"^",11),LRQ("D")=$P(X,"^",12),T=$S($D(^(2)):$P(^(2),"^",3),1:"") F A=10,11 S LRJ(A+.4)=$S($D(^(A)):$P(^(A),"^",4),1:"")

 F A=10:1:20 S (LRJ(A),LRE(A),LRW(A))=""

 F A=10:1:16,18,19 I $D(^LRE(LRQ,5,LRI,A)) S B=^(A),LRJ(A)=$P(B,"^"),LRW(A)=$P(B,"^",3),LRE(A)=$P(B,"^",2)

 F A=17,20 I $G(LRH(A)),$D(^LRE(LRQ,5,LRI,A)) S B=^(A),LRJ(A)=$P(B,U),LRW(A)=$P(B,U,3),LRE(A)=$P(B,U,2)

 S V=$P(X,"^",10),V(10)=LRJ(10),V(11)=LRJ(11),V(12)=V(10)_" "_V(11),LRJ(1)=$P(X,"^",2),(W,LRJ(6.1))=$P(X,"^",10)

 F A=1,6.1,10:1:16,18,19 S X=LRJ(A),B=LRB(A),X=$S(X]"":$P($P(B,X_":",2),";"),1:"") S LRJ(A)=X

 F A=17,20 I $G(LRH(A)) S X=LRJ(A),B=LRB(A),X=$S(X]"":$P($P(B,X_":",2),";"),1:"") S LRJ(A)=X

 W @IOF I LRQ("S")]"","AD"[LRQ("S") W $C(7)

 ;W $S(LRQ("S")="A":"AUTOLOGOUS ",LRQ("S")="D":"DIRECTED ",1:" ") I LRQ("D") W "For: " S X=^LR(LRQ("D"),0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),SSN=$P(X,"^",9) D SSN^LRU W $P(X,"^")," ",SSN

 W $S(LRQ("S")="A":"AUTOLOGOUS ",LRQ("S")="D":"DIRECTED ",1:" ")

 I LRQ("D") W "For: " S X=^LR(LRQ("D"),0),(DFN,Y)=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),SSN=$P(X,"^",9) D SSN^LRU W $P(X,"^")," ",HRCN  ;IHS/DIR TUC/AAB 04/29/98

 W ?53,"Unit: ",LRG

 W !,"Unit testing:",?70,"Tech" F A=10:1:16,18,19 D W

 F A=17,20 I $G(LRH(A)) D W

 I LRJ(10)=""!(LRJ(11)="") W $C(7),!,"Must perform ABO/Rh testing !!",! D FRE^LRBLDRR1 Q

 I LRA S A=0 D EN1^LRBLDRR2 Q:A

 I LRJ(10)'=LRQ(5) W $C(7),!,"Donor ABO (",LRQ(5),") is different from unit ABO (",LRJ(10),"). Resolve discrepancy." S LRD=1

 I $E(LRJ(11),1,3)'=LRQ(6) W $C(7),!,"Donor Rh (",LRQ(6),") is different from unit Rh (",$E(LRJ(11),1,3),").  Resolve discrepancy." S LRD=1

 I $D(LRD),'$D(^XUSEC("LRBLSUPER",DUZ)) D FRE^LRBLDRR1 Q

 I $D(LRD) K LRD D SUPER I $D(LRY) K LRY Q

 K F S A=0 F B=1:1 S A=$O(^LRE(LRQ,5,LRI,66,A)) Q:'A  S X=^(A,0) D S

 I B<2 W $C(7),!!,"No components prepared !",! D FRE^LRBLDRR1 Q

 S Y=T D D^LRU W !!,"Donation: ",LRJ(1),?36,"Collection completed: ",Y,!?5,"Component",?36,"Date/time stored",?58,"Expiration date" S A=0

 F B=0:1 S A=$O(F(A)) Q:'A  S L=$P(F(A),U,9) W !,$J(A,2),".",?5,$P(F(A),U,4),?27,$S(L=2:"Discard",L=1:"Quarant",$P(F(A),U,3)]"":"released",$P(F(A),U,2)]"":"labeled",1:""),?36,$P(F(A),U,5),?58,$P(F(A),U,6)

 I V W $C(7),!!,LRN(6.1),": ",LRJ(6.1) Q

 D ^LRBLDRR1 Q

SUPER W !!,"If you continue with label/release of ",LRG," a message will be",!,"sent to all users holding the blood bank supervisor's key.",!,"Do you want to continue with label/release of ",LRG S %=2 D YN^LRU I %=2 D FRE^LRBLDRR1 S LRY=1 Q

 S LR("TXT",1,0)="Blood donor unit ID: "_LRG,LR("KEY")="LRBLSUPER",LR("SUB")="Donor unit label/release with ABO/Rh discrepancy",LR("TXT",2,0)=" Component(s) have been labeled/released with ABO/Rh donor/unit ID discrepancy"

 D ^LRUMSG Q

ASK S LRQ=+Y,DIC="^LRE(LRQ,5,",DIC(0)="FAEQM",DIC("A")="Select DONATION DATE: " D ^DIC K DIC I X["^"!(X="") S Y=-1 Q

 S LRI=+Y,LRG=$P(^LRE(LRQ,5,LRI,0),U,4) Q

E D V^LRU Q

W W !?5,LRN(A),?36,": ",LRJ(A),?70,$S(LRE(A)="":"",$D(^VA(200,LRE(A),0)):$P(^(0),"^",2),1:LRE(A)) I LRW(A)]"" W !,LRW(A)

 Q

LRBLDRR   ; IHS/DIR/AAB - REVIEW/RELEASE COMPONENTS 1/24/97 11:04 ; [ 02/03/1999  2:08 PM ]

 +1       ;;5.2;LR;**1002,1003**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72,90,97**;Sep 27, 1994

 +3        DO E

           SET LR("M")=1

           SET X="BLOOD BANK"

           DO ^LRUTL

           IF Y=-1

               GOTO E

           DO D^LRBLU

           IF '$DATA(X)

               GOTO E

 +4        IF LRCAPA

               SET X="DONOR UNIT LABELING"

               DO X^LRUWK

               IF '$DATA(X)

                   GOTO E

               SET Y="RR"

               DO S^LRBLWD

               KILL LRT

               SET X="UNIT LOG-IN/SEND-OUT"

               DO X^LRUWK

               IF '$DATA(X)

                   GOTO E

 +5        SET LRA=$SELECT($DATA(^LAB(69.9,1,8,1,0)):$PIECE(^(0),"^",2),1:0)

           SET Y="LG"

           IF LRCAPA

               DO S^LRBLWD

 +6        WRITE !!?20,"Review-label-release components",!!?20,LRAA(4),!

           DO BAR^LRBLB

           IF LR

               WRITE !!?15,"STANDARD UNIT ID LABELING "

               SET %=1

               DO YN^LRU

               IF %<1

                   GOTO E

               SET LR(3)=$SELECT(%=1:"",1:1)

 +7        FOR A=1,6.1,10:1:16,18,19

               Begin DoDot:1

 +8                DO FIELD^DID(65.54,A,"","POINTER","LRB")

                   SET LRB(A)=LRB("POINTER")

 +9                DO FIELD^DID(65.54,A,"","LABEL","LRN")

                   SET LRN(A)=LRN("LABEL")

               End DoDot:1

 +10       FOR A=17,20

               IF $GET(LRH(A))

                   Begin DoDot:1

 +11                   DO FIELD^DID(65.54,A,"","POINTER","LRB")

                       SET LRB(A)=LRB("POINTER")

 +12                   DO FIELD^DID(65.54,A,"","LABEL","LRN")

                       SET LRN(A)=LRN("LABEL")

                   End DoDot:1

P          READ !!,"Select UNIT FOR LABEL/RELEASE: ",X:DTIME

           IF LR

               DO U^LRBLB

 +1        WRITE !

           SET DIC="^LRE("

           SET DIC(0)="FQMZ"

           SET D="C^B"

           DO MIX^DIC1

           KILL DIC

           IF X[U!(X="")

               GOTO E

           IF Y<1

               GOTO P

           SET LRQ(5)=$PIECE(Y(0),"^",5)

           SET LRQ(6)=$PIECE(Y(0),"^",6)

           SET LRQ("X")=0

 +2        IF X[","

               DO ASK

               IF Y<1

                   GOTO P

               DO REST

               GOTO P

 +3        SET LRQ=+Y

           SET LRI=$ORDER(^LRE("C",X,LRQ,0))

           IF 'LRI

               GOTO P

           LOCK +^LRE(LRQ,5,LRI):5

           IF '$TEST

               WRITE !,$CHAR(7),"Someone else is editing this entry! "

               GOTO P

 +4        SET LRG=$PIECE(^LRE(LRQ,5,LRI,0),"^",4)

           DO REST

           GOTO P

 +5       ;

S          SET F=^LAB(66,A,0)

           SET Y=$PIECE(X,"^",3)

           DO D^LRU

           SET S=Y

           SET Y=$PIECE(X,"^",4)

           DO D^LRU

 +1        SET F(B)=$PIECE(X,"^",2)_"^"_$PIECE(X,"^",6)_"^"_$PIECE(X,"^",7)_"^"_$EXTRACT($PIECE(F,"^"),1,21)_"^"_S_"^"_Y_"^"_A_"^"_$PIECE(F,"^",9)_"^"_$PIECE(X,"^",8)_"^"_$PIECE(F,"^",19)

           QUIT 

 +2       ;

REST       SET LRV=$PIECE(^LRE(LRQ,0),"^",15)

           SET X=^(5,LRI,0)

           SET LRQ("S")=$PIECE(X,"^",11)

           SET LRQ("D")=$PIECE(X,"^",12)

           SET T=$SELECT($DATA(^(2)):$PIECE(^(2),"^",3),1:"")

           FOR A=10,11

               SET LRJ(A+.4)=$SELECT($DATA(^(A)):$PIECE(^(A),"^",4),1:"")

 +1        FOR A=10:1:20

               SET (LRJ(A),LRE(A),LRW(A))=""

 +2        FOR A=10:1:16,18,19

               IF $DATA(^LRE(LRQ,5,LRI,A))

                   SET B=^(A)

                   SET LRJ(A)=$PIECE(B,"^")

                   SET LRW(A)=$PIECE(B,"^",3)

                   SET LRE(A)=$PIECE(B,"^",2)

 +3        FOR A=17,20

               IF $GET(LRH(A))

                   IF $DATA(^LRE(LRQ,5,LRI,A))

                       SET B=^(A)

                       SET LRJ(A)=$PIECE(B,U)

                       SET LRW(A)=$PIECE(B,U,3)

                       SET LRE(A)=$PIECE(B,U,2)

 +4        SET V=$PIECE(X,"^",10)

           SET V(10)=LRJ(10)

           SET V(11)=LRJ(11)

           SET V(12)=V(10)_" "_V(11)

           SET LRJ(1)=$PIECE(X,"^",2)

           SET (W,LRJ(6.1))=$PIECE(X,"^",10)

 +5        FOR A=1,6.1,10:1:16,18,19

               SET X=LRJ(A)

               SET B=LRB(A)

               SET X=$SELECT(X]"":$PIECE($PIECE(B,X_":",2),";"),1:"")

               SET LRJ(A)=X

 +6        FOR A=17,20

               IF $GET(LRH(A))

                   SET X=LRJ(A)

                   SET B=LRB(A)

                   SET X=$SELECT(X]"":$PIECE($PIECE(B,X_":",2),";"),1:"")

                   SET LRJ(A)=X

 +7        WRITE @IOF

           IF LRQ("S")]""

               IF "AD"[LRQ("S")

                   WRITE $CHAR(7)

 +8       ;W $S(LRQ("S")="A":"AUTOLOGOUS ",LRQ("S")="D":"DIRECTED ",1:" ") I LRQ("D") W "For: " S X=^LR(LRQ("D"),0),Y=$P">P">P">P">P">P">P">P(X,"^",3),(LRDP">P">P">P">P">P">P">PF,X)=$P">P">P">P">P">P">P">P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),SSN=$P">P">P">P">P">P">P">P(X,"^",9) D SSN^LRU W $P">P">P">P">P">P">P">P(X,"^")," ",SSN

 +9        WRITE $SELECT(LRQ("S")="A":"AUTOLOGOUS ",LRQ("S")="D":"DIRECTED ",1:" ")

 +10      ;IHS/DIR TUC/AAB 04/29/98

           IF LRQ("D")

               WRITE "For: "

               SET X=^LR(LRQ("D"),0)

               SET (DFN,Y)=$PIECE(X,"^",3)

               SET (LRDPF,X)=$PIECE(X,"^",2)

               SET X=^DIC(X,0,"GL")

               SET X=@(X_Y_",0)")

               SET SSN=$PIECE(X,"^",9)

               DO SSN^LRU

               WRITE $PIECE(X,"^")," ",HRCN

 +11       WRITE ?53,"Unit: ",LRG

 +12       WRITE !,"Unit testing:",?70,"Tech"

           FOR A=10:1:16,18,19

               DO W

 +13       FOR A=17,20

               IF $GET(LRH(A))

                   DO W

 +14       IF LRJ(10)=""!(LRJ(11)="")

               WRITE $CHAR(7),!,"Must perform ABO/Rh testing !!",!

               DO FRE^LRBLDRR1

               QUIT 

 +15       IF LRA

               SET A=0

               DO EN1^LRBLDRR2

               IF A

                   QUIT 

 +16       IF LRJ(10)'=LRQ(5)

               WRITE $CHAR(7),!,"Donor ABO (",LRQ(5),") is different from unit ABO (",LRJ(10),"). Resolve discrepancy."

               SET LRD=1

 +17       IF $EXTRACT(LRJ(11),1,3)'=LRQ(6)

               WRITE $CHAR(7),!,"Donor Rh (",LRQ(6),") is different from unit Rh (",$EXTRACT(LRJ(11),1,3),").  Resolve discrepancy."

               SET LRD=1

 +18       IF $DATA(LRD)

               IF '$DATA(^XUSEC("LRBLSUPER",DUZ))

                   DO FRE^LRBLDRR1

                   QUIT 

 +19       IF $DATA(LRD)

               KILL LRD

               DO SUPER

               IF $DATA(LRY)

                   KILL LRY

                   QUIT 

 +20       KILL F

           SET A=0

           FOR B=1:1

               SET A=$ORDER(^LRE(LRQ,5,LRI,66,A))

               IF 'A

                   QUIT 

               SET X=^(A,0)

               DO S

 +21       IF B<2

               WRITE $CHAR(7),!!,"No components prepared !",!

               DO FRE^LRBLDRR1

               QUIT 

 +22       SET Y=T

           DO D^LRU

           WRITE !!,"Donation: ",LRJ(1),?36,"Collection completed: ",Y,!?5,"Component",?36,"Date/time stored",?58,"Expiration date"

           SET A=0

 +23       FOR B=0:1

               SET A=$ORDER(F(A))

               IF 'A

                   QUIT 

               SET L=$PIECE(F(A),U,9)

               WRITE !,$JUSTIFY(A,2),".",?5,$PIECE(F(A),U,4),?27,$SELECT(L=2:"Discard",L=1:"Quarant",$PIECE(F(A),U,3)]"":"released",$PIECE(F(A),U,2)]"":"labeled",1:""),?36,$PIECE(F(A),U,5),?58,$PIECE(F(A),U,6)

 +24       IF V

               WRITE $CHAR(7),!!,LRN(6.1),": ",LRJ(6.1)

               QUIT 

 +25       DO ^LRBLDRR1

           QUIT 

SUPER      WRITE !!,"If you continue with label/release of ",LRG," a message will be",!,"sent to all users holding the blood bank supervisor's key.",!,"Do you want to continue with label/release of ",LRG

           SET %=2

           DO YN^LRU

           IF %=2

               DO FRE^LRBLDRR1

               SET LRY=1

               QUIT 

 +1        SET LR("TXT",1,0)="Blood donor unit ID: "_LRG

           SET LR("KEY")="LRBLSUPER"

           SET LR("SUB")="Donor unit label/release with ABO/Rh discrepancy"

           SET LR("TXT",2,0)=" Component(s) have been labeled/released with ABO/Rh donor/unit ID discrepancy"

 +2        DO ^LRUMSG

           QUIT 

ASK        SET LRQ=+Y

           SET DIC="^LRE(LRQ,5,"

           SET DIC(0)="FAEQM"

           SET DIC("A")="Select DONATION DATE: "

           DO ^DIC

           KILL DIC

           IF X["^"!(X="")

               SET Y=-1

               QUIT 

 +1        SET LRI=+Y

           SET LRG=$PIECE(^LRE(LRQ,5,LRI,0),U,4)

           QUIT 

E          DO V^LRU

           QUIT 

W          WRITE !?5,LRN(A),?36,": ",LRJ(A),?70,$SELECT(LRE(A)="":"",$DATA(^VA(200,LRE(A),0)):$PIECE(^(0),"^",2),1:LRE(A))

           IF LRW(A)]""

               WRITE !,LRW(A)

 +1        QUIT