LRBLDL ;AVAMC/REG - BLOOD DONOR LIST ;2/18/93 08:55 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
W @IOF,!?28,"BLOOD DONOR LISTS/LABELS"
S LR(2)="",LR=0,%DT="AEX",%DT(0)="-N",%DT("A")="Date since last donation: " D ^%DT K %DT G:Y<1 END S LRSDT=9999998-Y D D^LRU S LRSTR=Y
W !!,"DONORS FROM A SPECIFIC GROUP AFFILIATION " S %=2 D YN^LRU G:%<1 END
I %=1 S DIC=65.4,DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)[""G""",DIC("A")="Select DONOR GROUP AFFILIATION: " D ^DIC K DIC G:X=""!(X[U) END S LR=+Y,LR(2)=$P(Y,U,2)
S R !!,"START WITH BLOOD DONOR NAME: FIRST// ",X:DTIME G:X[U!'$T END I X="" S P(1)=0,P(2)="z" G L
I X["?"!(X'?1U.E)!($L(X)>30) D H^LRU G S
S P(1)=X I $L(X)>1 S X(1)=$A(X,$L(X))-1,X(1)=$C(X(1)),P(1)=$E(X,1,$L(X)-1)_X(1)
F R !,"GO TO BLOOD DONOR NAME: LAST// ",X:DTIME G:X[U!'$T END I X="" S P(2)="z" G L
I X["?"!(X'?1U.E)!($L(X)>30) D H1^LRU G F
S P(2)=X
L W !!?14,"1. PRINT DONOR LIST",!?14,"2. PRINT DONOR LABELS",!,"Select (1-2): " R X:DTIME Q:X=""!(X[U) I X'=1&(X'=2) W $C(7),!,"Enter the number 1 or the number 2" G L
G:X=2 B S ZTRTN="QUE^LRBLDL" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D L^LRU,S^LRU,H S LR("F")=1
S P=P(1) F A=0:1 S P=$O(^LRE("B",P)) Q:P=""!(P]P(2))!(LR("Q")) F I=0:0 S I=$O(^LRE("B",P,I)) Q:I<1!(LR("Q")) S W=$O(^LRE(I,5,0)) I W>LRSDT S W=^(W,0) D W
D END,END^LRUTL Q
;
W Q:$P(^LRE(I,0),"^",10) D:$Y>(IOSL-11) H Q:LR("Q") S W(7)=$P(W,"^",7) I LR,W(7)'=LR,'$D(^LRE(I,2,LR)) Q
W !,P S Y=+W D D^LRU W ?31,$E(Y,1,12) I W(7),$D(^LAB(65.4,W(7),0)) W ?45,$E($P(^(0),"^",3),1,30)
I $D(^LRE(I,1)) S X=^(1),Y=$P(X,"^",7),O=$P(X,"^",8) W:IOM>118 ?76,Y,?93,O W:IOM<119&(Y]""!(O]"")) !?5,Y,?25,O
F B=0:0 S B=$O(^LRE(I,2,B)) Q:'B!(LR("Q")) I B'=W(7),$D(^LAB(65.4,B,0)) W !?45,$E($P(^(0),"^",3),1,30)
Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRAA(1),!,LR(2)," NO DONATIONS SINCE ",LRSTR
W !,"Donor",?31,"Last donation",?55,"Group" W:IOM>118 ?76,"Home phone",?93,"Work phone" W:IOM<119 !?5,"Home phone",?25,"Work phone" W !,LR("%") Q
;
B W !!?33,"REMEMBER TO",!?13,"ALIGN THE PRINT HEAD ON THE FIRST LINE OF THE LABEL" S LR(1)=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),"^",7),1:"")
I W !!?20,"ENTER NUMBER OF LINES FROM",!?20,"TOP OF ONE LABEL TO ANOTHER: ",LR(1),$S(LR(1):"// ",1:"") R X:DTIME Q:'$T!(X[U) S X=$S(X="":LR(1),$L(X)>2:X=1,1:X)
X $P(^DD(69.2,.07,0),"^",5,99) I '$D(X) W:$D(^DD(69.2,.07,3)) !,$C(7),^(3) X:$D(^(4)) ^(4) G I
S LR(1)=X
S ZTRTN="^LRBLDL1" D BEG^LRUTL G:POP!($D(ZTSK)) END
W ! G ^LRBLDL1
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDL 2663 printed Sep 23, 2025@19:46:15 Page 2
LRBLDL ;AVAMC/REG - BLOOD DONOR LIST ;2/18/93 08:55 ;
+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 DO END
SET X="BLOOD BANK"
DO ^LRUTL
if Y=-1
GOTO END
+4 WRITE @IOF,!?28,"BLOOD DONOR LISTS/LABELS"
+5 SET LR(2)=""
SET LR=0
SET %DT="AEX"
SET %DT(0)="-N"
SET %DT("A")="Date since last donation: "
DO ^%DT
KILL %DT
if Y<1
GOTO END
SET LRSDT=9999998-Y
DO D^LRU
SET LRSTR=Y
+6 WRITE !!,"DONORS FROM A SPECIFIC GROUP AFFILIATION "
SET %=2
DO YN^LRU
if %<1
GOTO END
+7 IF %=1
SET DIC=65.4
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,2)[""G"""
SET DIC("A")="Select DONOR GROUP AFFILIATION: "
DO ^DIC
KILL DIC
if X=""!(X[U)
GOTO END
SET LR=+Y
SET LR(2)=$PIECE(Y,U,2)
S READ !!,"START WITH BLOOD DONOR NAME: FIRST// ",X:DTIME
if X[U!'$TEST
GOTO END
IF X=""
SET P(1)=0
SET P(2)="z"
GOTO L
+1 IF X["?"!(X'?1U.E)!($LENGTH(X)>30)
DO H^LRU
GOTO S
+2 SET P(1)=X
IF $LENGTH(X)>1
SET X(1)=$ASCII(X,$LENGTH(X))-1
SET X(1)=$CHAR(X(1))
SET P(1)=$EXTRACT(X,1,$LENGTH(X)-1)_X(1)
F READ !,"GO TO BLOOD DONOR NAME: LAST// ",X:DTIME
if X[U!'$TEST
GOTO END
IF X=""
SET P(2)="z"
GOTO L
+1 IF X["?"!(X'?1U.E)!($LENGTH(X)>30)
DO H1^LRU
GOTO F
+2 SET P(2)=X
L WRITE !!?14,"1. PRINT DONOR LIST",!?14,"2. PRINT DONOR LABELS",!,"Select (1-2): "
READ X:DTIME
if X=""!(X[U)
QUIT
IF X'=1&(X'=2)
WRITE $CHAR(7),!,"Enter the number 1 or the number 2"
GOTO L
+1 if X=2
GOTO B
SET ZTRTN="QUE^LRBLDL"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO L^LRU
DO S^LRU
DO H
SET LR("F")=1
+1 SET P=P(1)
FOR A=0:1
SET P=$ORDER(^LRE("B",P))
if P=""!(P]P(2))!(LR("Q"))
QUIT
FOR I=0:0
SET I=$ORDER(^LRE("B",P,I))
if I<1!(LR("Q"))
QUIT
SET W=$ORDER(^LRE(I,5,0))
IF W>LRSDT
SET W=^(W,0)
DO W
+2 DO END
DO END^LRUTL
QUIT
+3 ;
W if $PIECE(^LRE(I,0),"^",10)
QUIT
if $Y>(IOSL-11)
DO H
if LR("Q")
QUIT
SET W(7)=$PIECE(W,"^",7)
IF LR
IF W(7)'=LR
IF '$DATA(^LRE(I,2,LR))
QUIT
+1 WRITE !,P
SET Y=+W
DO D^LRU
WRITE ?31,$EXTRACT(Y,1,12)
IF W(7)
IF $DATA(^LAB(65.4,W(7),0))
WRITE ?45,$EXTRACT($PIECE(^(0),"^",3),1,30)
+2 IF $DATA(^LRE(I,1))
SET X=^(1)
SET Y=$PIECE(X,"^",7)
SET O=$PIECE(X,"^",8)
if IOM>118
WRITE ?76,Y,?93,O
if IOM<119&(Y]""!(O]""))
WRITE !?5,Y,?25,O
+3 FOR B=0:0
SET B=$ORDER(^LRE(I,2,B))
if 'B!(LR("Q"))
QUIT
IF B'=W(7)
IF $DATA(^LAB(65.4,B,0))
WRITE !?45,$EXTRACT($PIECE(^(0),"^",3),1,30)
+4 QUIT
+5 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRAA(1),!,LR(2)," NO DONATIONS SINCE ",LRSTR
+2 WRITE !,"Donor",?31,"Last donation",?55,"Group"
if IOM>118
WRITE ?76,"Home phone",?93,"Work phone"
if IOM<119
WRITE !?5,"Home phone",?25,"Work phone"
WRITE !,LR("%")
QUIT
+3 ;
B WRITE !!?33,"REMEMBER TO",!?13,"ALIGN THE PRINT HEAD ON THE FIRST LINE OF THE LABEL"
SET LR(1)=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),"^",7),1:"")
I WRITE !!?20,"ENTER NUMBER OF LINES FROM",!?20,"TOP OF ONE LABEL TO ANOTHER: ",LR(1),$SELECT(LR(1):"// ",1:"")
READ X:DTIME
if '$TEST!(X[U)
QUIT
SET X=$SELECT(X="":LR(1),$LENGTH(X)>2:X=1,1:X)
+1 XECUTE $PIECE(^DD(69.2,.07,0),"^",5,99)
IF '$DATA(X)
if $DATA(^DD(69.2,.07,3))
WRITE !,$CHAR(7),^(3)
if $DATA(^(4))
XECUTE ^(4)
GOTO I
+2 SET LR(1)=X
+3 SET ZTRTN="^LRBLDL1"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
+4 WRITE !
GOTO ^LRBLDL1
+5 ;
END DO V^LRU
QUIT
