LRBLD.m

LRBLD ;AVAMC/REG - CK BLOOD DONOR ENTRY ; 10/19/88  18:28 ;

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

 ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021

 K Z S T=$P(Y(0),U,3),S=$P(Y(0),U,2),X=$F(LRP,","),Y=$A($E(LRP,X))+1,Y=$C(Y),Y=$P(LRP,",")_","_Y,X=$E(LRP,1,X)

 S F=0,A=X F B=0:0 S A=$O(^LRE("B",A)) Q:A=""!(A]Y)  F C=0:0 S C=$O(^LRE("B",A,C)) Q:'C  S W=^LRE(C,0) I C'=DA,S=$P(W,"^",2) S F=F+1 D W

 I $D(Z) W !,"Your entry: ",LRP,?43,"DOB: ",$E(T,4,5)_"/"_$E(T,6,7)_"/"_$E(T,2,3),!!,"Want to delete your entry " S %=2 D YN^LRU I %=1 S DIK="^LRE(" D ^DIK K DIK,DA W !!,"Ok, ",LRP," deleted.",!

 K A,B,C,E,F,X,Y,Z Q

W W:F=1 !!,"Donors with same last name, first name initial and sex as your entry:",! D:F#20=0 M S Z=$P(^LRE(C,0),"^",3) W ?12,A,?43,"DOB: ",$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3),! Q

 ;

M R "Press <CR>, 'ENTER' or 'RETURN' key: ",X(1):DTIME W $C(13),$J("",80),$C(13) Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRBLD   933     printed  Apr 09, 2024@21:18:43                                                                                                                                                                                                        Page 2

LRBLD     ;AVAMC/REG - CK BLOOD DONOR ENTRY ; 10/19/88  18:28 ;

 +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        KILL Z

           SET T=$PIECE(Y(0),U,3)

           SET S=$PIECE(Y(0),U,2)

           SET X=$FIND(LRP,",")

           SET Y=$ASCII($EXTRACT(LRP,X))+1

           SET Y=$CHAR(Y)

           SET Y=$PIECE(LRP,",")_","_Y

           SET X=$EXTRACT(LRP,1,X)

 +4        SET F=0

           SET A=X

           FOR B=0:0

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

               if A=""!(A]Y)

                   QUIT 

               FOR C=0:0

                   SET C=$ORDER(^LRE("B",A,C))

                   if 'C

                       QUIT 

                   SET W=^LRE(C,0)

                   IF C'=DA

                       IF S=$PIECE(W,"^",2)

                           SET F=F+1

                           DO W

 +5        IF $DATA(Z)

               WRITE !,"Your entry: ",LRP,?43,"DOB: ",$EXTRACT(T,4,5)_"/"_$EXTRACT(T,6,7)_"/"_$EXTRACT(T,2,3),!!,"Want to delete your entry "

               SET %=2

               DO YN^LRU

               IF %=1

                   SET DIK="^LRE("

                   DO ^DIK

                   KILL DIK,DA

                   WRITE !!,"Ok, ",LRP," deleted.",!

 +6        KILL A,B,C,E,F,X,Y,Z

           QUIT 

W          if F=1

               WRITE !!,"Donors with same last name, first name initial and sex as your entry:",!

           if F#20=0

               DO M

           SET Z=$PIECE(^LRE(C,0),"^",3)

           WRITE ?12,A,?43,"DOB: ",$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_$EXTRACT(Z,2,3),!

           QUIT 

 +1       ;

M          READ "Press <CR>, 'ENTER' or 'RETURN' key: ",X(1):DTIME

           WRITE $CHAR(13),$JUSTIFY("",80),$CHAR(13)

           QUIT