- 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 23, 2025@18:24:21 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
