LRBLDA1 ;AVAMC/REG - BLOOD DONOR LABELS ; 10/23/88 15:45 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDA1 1458 printed Apr 09, 2024@21:16:26 Page 2
LRBLDA1 ;AVAMC/REG - BLOOD DONOR LABELS ; 10/23/88 15:45 ;
+1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 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
