LRBLDA1.m

LRBLDA1 ; IHS/DIR/FJE - BLOOD DONOR LABELS 10/23/88 15:45 ;

 ;;5.2;LR;;NOV 01, 1997

 ;

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 U IO S LRP=LRP(1) F LRA=0:1 S LRP=$O(^LRE("B",LRP)) G:LRP=""!(LRP]LRP(2)) END F LRI=0:0 S LRI=$O(^LRE("B",LRP,LRI)) Q:'LRI  S LRW=$O(^LRE(LRI,5,0)) I LRW>LRSDT S LRW=^(LRW,0) D W

END D END^LRUTL,V^LRU Q

 ;

W S X=^LRE(LRI,0) Q:$P(X,"^",10)  Q:LRABO]""&($P(X,"^",5)'=LRABO)  Q:LRRH]""&($P(X,"^",6)'=LRRH)

 S LRW(7)=$P(LRW,"^",7) I LR,LRW(7)'=LR,'$D(^LRE(LRI,2,LR)) Q

 S C=1 W $P(LRP,",",2)_" "_$P(LRP,",")

 I $D(^LRE(LRI,1)) S X=^(1) D A

 F B=C:1:LR(1) W !

 Q

A F B=1:1:3 I $P(X,"^",B)]"" S C=C+1 W !,$P(X,"^",B)

 S C=C+1 W !,$P(X,"^",4) W:$P(X,"^",5) ", ",$P(^DIC(5,$P(X,"^",5),0),"^",2) W " ",$P(X,"^",6) Q

EN ;

AB R !,"ABO GROUP: ",X:DTIME I '$T!(X[U) K Y Q

 I X'=""&(X'="A")&(X'="B")&(X'="O")&(X'="AB") W $C(7),!!,"Enter A, O, B or AB" G AB

 S LRABO=X

R R !,"Rh TYPE: ",X:DTIME I '$T!(X[U) K Y Q

 I X'=""&(X'="P")&(X'="N") W $C(7),!!,"Enter P for POS or N for NEG" G R

 S LRRH=$S(X="N":"NEG",X="P":"POS",1:"") Q

EN1 ;RBC ANTIGENS ABSENT

 W !

B S DIC="^LAB(61.3,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,5)=""AN""",DIC("A")="Select RBC ANTIGEN ABSENT: " D ^DIC K DIC I Y>0 S LRJ(+Y)=$P(Y,U,2) G B

 S (B,X)="" F A=0:0 S A=$O(LRJ(A)) Q:'A  S B=B_LRJ(A)_", ",X=X+1

 S B=$E(B,1,$L(B)-2) I X>1 S B=$P(B,", ",1,X-1)_" and "_$P(B,", ",X)

 S LRF=B Q

LRBLDA1   ; IHS/DIR/FJE - BLOOD DONOR LABELS 10/23/88 15:45 ;

 +1       ;;5.2;LR;;NOV 01, 1997

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4        USE IO

           SET LRP=LRP(1)

           FOR LRA=0:1

               SET LRP=$ORDER(^LRE("B",LRP))

               IF LRP=""!(LRP]LRP(2))

                   GOTO END

               FOR LRI=0:0

                   SET LRI=$ORDER(^LRE("B",LRP,LRI))

                   IF 'LRI

                       QUIT 

                   SET LRW=$ORDER(^LRE(LRI,5,0))

                   IF LRW>LRSDT

                       SET LRW=^(LRW,0)

                       DO W

END        DO END^LRUTL

           DO V^LRU

           QUIT 

 +1       ;

W          SET X=^LRE(LRI,0)

           IF $PIECE(X,"^",10)

               QUIT 

           IF LRABO]""&($PIECE(X,"^",5)'=LRABO)

               QUIT 

           IF LRRH]""&($PIECE(X,"^",6)'=LRRH)

               QUIT 

 +1        SET LRW(7)=$PIECE(LRW,"^",7)

           IF LR

               IF LRW(7)'=LR

                   IF '$DATA(^LRE(LRI,2,LR))

                       QUIT 

 +2        SET C=1

           WRITE $PIECE(LRP,",",2)_" "_$PIECE(LRP,",")

 +3        IF $DATA(^LRE(LRI,1))

               SET X=^(1)

               DO A

 +4        FOR B=C:1:LR(1)

               WRITE !

 +5        QUIT 

A          FOR B=1:1:3

               IF $PIECE(X,"^",B)]""

                   SET C=C+1

                   WRITE !,$PIECE(X,"^",B)

 +1        SET C=C+1

           WRITE !,$PIECE(X,"^",4)

           IF $PIECE(X,"^",5)

               WRITE ", ",$PIECE(^DIC(5,$PIECE(X,"^",5),0),"^",2)

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

           QUIT 

EN        ;

AB         READ !,"ABO GROUP: ",X:DTIME

           IF '$TEST!(X[U)

               KILL Y

               QUIT 

 +1        IF X'=""&(X'="A")&(X'="B")&(X'="O")&(X'="AB")

               WRITE $CHAR(7),!!,"Enter A, O, B or AB"

               GOTO AB

 +2        SET LRABO=X

R          READ !,"Rh TYPE: ",X:DTIME

           IF '$TEST!(X[U)

               KILL Y

               QUIT 

 +1        IF X'=""&(X'="P")&(X'="N")

               WRITE $CHAR(7),!!,"Enter P for POS or N for NEG"

               GOTO R

 +2        SET LRRH=$SELECT(X="N":"NEG",X="P":"POS",1:"")

           QUIT 

EN1       ;RBC ANTIGENS ABSENT

 +1        WRITE !

B          SET DIC="^LAB(61.3,"

           SET DIC(0)="AEQM"

           SET DIC("S")="I $P(^(0),U,5)=""AN"""

           SET DIC("A")="Select RBC ANTIGEN ABSENT: "

           DO ^DIC

           KILL DIC

           IF Y>0

               SET LRJ(+Y)=$PIECE(Y,U,2)

               GOTO B

 +1        SET (B,X)=""

           FOR A=0:0

               SET A=$ORDER(LRJ(A))

               IF 'A

                   QUIT 

               SET B=B_LRJ(A)_", "

               SET X=X+1

 +2        SET B=$EXTRACT(B,1,$LENGTH(B)-2)

           IF X>1

               SET B=$PIECE(B,", ",1,X-1)_" and "_$PIECE(B,", ",X)

 +3        SET LRF=B

           QUIT