LRBLDL1.m

LRBLDL1 ;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 P=P(1) F A=0:1 S P=$O(^LRE("B",P)) G:P=""!(P]P(2)) END F I=0:0 S I=$O(^LRE("B",P,I)) Q:'I  S W=$O(^LRE(I,5,0)) I W>LRSDT S W=^(W,0) D W

END D V^LRU,END^LRUTL Q

 ;

W Q:$P(^LRE(I,0),"^",10)  S W(7)=$P(W,"^",7) I LR,W(7)'=LR,'$D(^LRE(I,2,LR)) Q

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

 I $D(^LRE(I,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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRBLDL1   692     printed  Apr 09, 2024@21:21:07                                                                                                                                                                                                      Page 2

LRBLDL1   ;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 P=P(1)

           FOR A=0:1

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

               if P=""!(P]P(2))

                   GOTO END

               FOR I=0:0

                   SET I=$ORDER(^LRE("B",P,I))

                   if 'I

                       QUIT 

                   SET W=$ORDER(^LRE(I,5,0))

                   IF W>LRSDT

                       SET W=^(W,0)

                       DO W

END        DO V^LRU

           DO END^LRUTL

           QUIT 

 +1       ;

W          if $PIECE(^LRE(I,0),"^",10)

               QUIT 

           SET W(7)=$PIECE(W,"^",7)

           IF LR

               IF W(7)'=LR

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

                       QUIT 

 +1        SET C=1

           WRITE $PIECE(P,",",2)_" "_$PIECE(P,",",1)

 +2        IF $DATA(^LRE(I,1))

               SET X=^(1)

               DO A

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

               WRITE !

 +4        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