LRBLDEX1 ;AVAMC/REG/CYM - EX-BLOOD DONORS ;7/3/96 20:44 ;
;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
S LRP=0 D H S LR("F")=1 F A=1:1 S LRP=$O(^LRO(69.2,LRAA,8,65.5,1,"B",LRP)) Q:LRP="" F LRI=0:0 S LRI=$O(^LRO(69.2,LRAA,8,65.5,1,"B",LRP,LRI)) Q:'LRI D L
G:LR("Q") OUT I $D(^TMP("LRBL",$J)) D H2 Q:LR("Q") S A=0 F B=0:0 S A=$O(^TMP("LRBL",$J,A)) Q:A=""!(LR("Q")) D:$Y>(IOSL-6) H2 Q:LR("Q") W !,A,?15,^TMP("LRBL",$J,A)
OUT K ^TMP("LRBL",$J) D V^LRU,END^LRUTL Q ;out
T Q:'Y S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) Q
;
L D:$Y>(IOSL-6) H Q:LR("Q") S W=^LRE(LRI,0),Y=$P(W,"^",3) D T W !,LRP," (Donor #: ",LRI,")",?40,Y,?49,$P(W,"^",2),?52,$J($P(W,"^",5),2),?55,$P(W,"^",6),?62,$S($P(W,"^",4)=1:"YES",1:"NO"),?73,$S($P(W,"^",10):"YES",1:"NO")
W !,"Reg/edited: " S Y=$P(W,"^",11) D T W Y W:$P(W,"^",7) " cum donations: ",$P(W,"^",7) W:$P(W,"^",8) " total awards: ",$P(W,"^",8) W:$P(W,"^",9) " demog ent/edit by:" S Y=$P(W,"^",9) D:Y EN1 W Y
K W I $D(^LRE(LRI,1)) S W=^(1),W(6)=$P(X,"^",6) W !,$P(W,"^")," ",$P(W,"^",2)," ",$P(W,"^",3)," ",$P(W,"^",4)," " S X=$P(W,"^",5) W $S(X:$P(^DIC(5,X,0),"^",2),1:"") W:W(6) " ",W(6)
I $D(W) S W(7)=$P(W,"^",7),W(8)=$P(W,"^",8) W:IOM<($X+22) ! W:W(7) " Home:",W(7) W:IOM<($X+22) ! W:W(8) " Work:",W(8)
D:$Y>(IOSL-6) EN Q:LR("Q") S W=0 F B=0:1 S W=$O(^LRE(LRI,1.1,W)) Q:'W!(LR("Q")) S W(1)=$P(^(W,0),"^",2) W:'B !,"RBC antigens present:" I $D(^LAB(61.3,W,0)) W:IOM<($X+31) ! W " ",$P(^(0),"^") W:W(1)]"" "(",W(1),")"
Q:LR("Q") D:$Y>(IOSL-6) EN Q:LR("Q") S W=0 F B=0:1 S W=$O(^LRE(LRI,1.2,W)) Q:'W S W(1)=$P(^(W,0),"^",2) W:'B !,"RBC antigens absent:" I $D(^LAB(61.3,W,0)) W:IOM<($X+31) ! W " ",$P(^(0),"^") W:W(1)]"" "(",W(1),")"
Q:LR("Q") D:$Y>(IOSL-6) EN Q:LR("Q") S W=0 F B=0:1 S W=$O(^LRE(LRI,1.3,W)) Q:'W S W(1)=$P(^(W,0),"^",2) W:'B !,"HLA antigens present:" I $D(^LAB(61.3,W,0)) W:IOM<($X+31) ! W " ",$P(^(0),"^") W:W(1)]"" "(",W(1),")"
Q:LR("Q") D:$Y>(IOSL-6) EN Q:LR("Q") S W=0 F B=0:1 S W=$O(^LRE(LRI,1.4,W)) Q:'W S W(1)=$P(^(W,0),"^",2) W:'B !,"HLA antigens absent:" I $D(^LAB(61.3,W,0)) W:IOM<($X+31) ! W " ",$P(^(0),"^") W:W(1)]"" "(",W(1),")"
Q:LR("Q") D:$Y>(IOSL-6) EN Q:LR("Q") S W=0 F B=0:1 S W=$O(^LRE(LRI,2,W)) Q:'W W:'B !,"Group affiliations:" I $D(^LAB(65.4,W,0)) W:IOM<($X+31) ! W " ",$P(^(0),"^")
Q:LR("Q") D:$Y>(IOSL-6) EN Q:LR("Q") S W=0 F B=0:1 S W=$O(^LRE(LRI,4,W)) Q:'W S X=^(W,0) W:'B !,"Donor scheduling/recall:" W:IOM<($X+10) ! W " ",$$EXTERNAL^DILFD(65.53,.01,"",X)
Q:LR("Q") D EN^LRBLDEX2 Q
EN1 ;also from LRBLDEX2
S Y=$S($D(^VA(200,Y,0)):$P(^(0),"^",2),1:Y) Q
;
HDR Q:LR("Q") I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRAA(1)," NO DONATIONS SINCE ",LRSTR Q
H D HDR Q:LR("Q") W !?10,"Donor (Reg #)",?42,"DOB",?48,"SEX",?52,"ABO/Rh",?59,"APHERESIS",?69,"PERM DEFER",!,LR("%") Q
EN ;from LRBLDEX2
D H Q:LR("Q") W !,LRP," (Donor #: ",LRI,") <continued from page ",LRQ-1,">" Q
H2 D HDR Q:LR("Q") W !,"Donor ID",?15,"DONOR NAME",!,LR("%")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDEX1 3086 printed Dec 13, 2024@02:10:33 Page 2
LRBLDEX1 ;AVAMC/REG/CYM - EX-BLOOD DONORS ;7/3/96 20:44 ;
+1 ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 SET LRP=0
DO H
SET LR("F")=1
FOR A=1:1
SET LRP=$ORDER(^LRO(69.2,LRAA,8,65.5,1,"B",LRP))
if LRP=""
QUIT
FOR LRI=0:0
SET LRI=$ORDER(^LRO(69.2,LRAA,8,65.5,1,"B",LRP,LRI))
if 'LRI
QUIT
DO L
+4 if LR("Q")
GOTO OUT
IF $DATA(^TMP("LRBL",$JOB))
DO H2
if LR("Q")
QUIT
SET A=0
FOR B=0:0
SET A=$ORDER(^TMP("LRBL",$JOB,A))
if A=""!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H2
if LR("Q")
QUIT
WRITE !,A,?15,^TMP("LRBL",$JOB,A)
OUT ;out
KILL ^TMP("LRBL",$JOB)
DO V^LRU
DO END^LRUTL
QUIT
T if 'Y
QUIT
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
QUIT
+1 ;
L if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
SET W=^LRE(LRI,0)
SET Y=$PIECE(W,"^",3)
DO T
WRITE !,LRP," (Donor #: ",LRI,")",?40,Y,?49,$PIECE(W,"^",2),?52,$JUSTIFY($PIECE(W,"^",5),2),?55,$PIECE(W,"^",6),?62,$SELECT($PIECE(W,"^",4)=1:"YES",1:"NO"),?73,$SELECT($PIECE(W,"^",10):"YES",1:"NO")
+1 WRITE !,"Reg/edited: "
SET Y=$PIECE(W,"^",11)
DO T
WRITE Y
if $PIECE(W,"^",7)
WRITE " cum donations: ",$PIECE(W,"^",7)
if $PIECE(W,"^",8)
WRITE " total awards: ",$PIECE(W,"^",8)
if $PIECE(W,"^",9)
WRITE " demog ent/edit by:"
SET Y=$PIECE(W,"^",9)
if Y
DO EN1
WRITE Y
+2 KILL W
IF $DATA(^LRE(LRI,1))
SET W=^(1)
SET W(6)=$PIECE(X,"^",6)
WRITE !,$PIECE(W,"^")," ",$PIECE(W,"^",2)," ",$PIECE(W,"^",3)," ",$PIECE(W,"^",4)," "
SET X=$PIECE(W,"^",5)
WRITE $SELECT(X:$PIECE(^DIC(5,X,0),"^",2),1:"")
if W(6)
WRITE " ",W(6)
+3 IF $DATA(W)
SET W(7)=$PIECE(W,"^",7)
SET W(8)=$PIECE(W,"^",8)
if IOM<($X+22)
WRITE !
if W(7)
WRITE " Home:",W(7)
if IOM<($X+22)
WRITE !
if W(8)
WRITE " Work:",W(8)
+4 if $Y>(IOSL-6)
DO EN
if LR("Q")
QUIT
SET W=0
FOR B=0:1
SET W=$ORDER(^LRE(LRI,1.1,W))
if 'W!(LR("Q"))
QUIT
SET W(1)=$PIECE(^(W,0),"^",2)
if 'B
WRITE !,"RBC antigens present:"
IF $DATA(^LAB(61.3,W,0))
if IOM<($X+31)
WRITE !
WRITE " ",$PIECE(^(0),"^")
if W(1)]""
WRITE "(",W(1),")"
+5 if LR("Q")
QUIT
if $Y>(IOSL-6)
DO EN
if LR("Q")
QUIT
SET W=0
FOR B=0:1
SET W=$ORDER(^LRE(LRI,1.2,W))
if 'W
QUIT
SET W(1)=$PIECE(^(W,0),"^",2)
if 'B
WRITE !,"RBC antigens absent:"
IF $DATA(^LAB(61.3,W,0))
if IOM<($X+31)
WRITE !
WRITE " ",$PIECE(^(0),"^")
if W(1)]""
WRITE "(",W(1),")"
+6 if LR("Q")
QUIT
if $Y>(IOSL-6)
DO EN
if LR("Q")
QUIT
SET W=0
FOR B=0:1
SET W=$ORDER(^LRE(LRI,1.3,W))
if 'W
QUIT
SET W(1)=$PIECE(^(W,0),"^",2)
if 'B
WRITE !,"HLA antigens present:"
IF $DATA(^LAB(61.3,W,0))
if IOM<($X+31)
WRITE !
WRITE " ",$PIECE(^(0),"^")
if W(1)]""
WRITE "(",W(1),")"
+7 if LR("Q")
QUIT
if $Y>(IOSL-6)
DO EN
if LR("Q")
QUIT
SET W=0
FOR B=0:1
SET W=$ORDER(^LRE(LRI,1.4,W))
if 'W
QUIT
SET W(1)=$PIECE(^(W,0),"^",2)
if 'B
WRITE !,"HLA antigens absent:"
IF $DATA(^LAB(61.3,W,0))
if IOM<($X+31)
WRITE !
WRITE " ",$PIECE(^(0),"^")
if W(1)]""
WRITE "(",W(1),")"
+8 if LR("Q")
QUIT
if $Y>(IOSL-6)
DO EN
if LR("Q")
QUIT
SET W=0
FOR B=0:1
SET W=$ORDER(^LRE(LRI,2,W))
if 'W
QUIT
if 'B
WRITE !,"Group affiliations:"
IF $DATA(^LAB(65.4,W,0))
if IOM<($X+31)
WRITE !
WRITE " ",$PIECE(^(0),"^")
+9 if LR("Q")
QUIT
if $Y>(IOSL-6)
DO EN
if LR("Q")
QUIT
SET W=0
FOR B=0:1
SET W=$ORDER(^LRE(LRI,4,W))
if 'W
QUIT
SET X=^(W,0)
if 'B
WRITE !,"Donor scheduling/recall:"
if IOM<($X+10)
WRITE !
WRITE " ",$$EXTERNAL^DILFD(65.53,.01,"",X)
+10 if LR("Q")
QUIT
DO EN^LRBLDEX2
QUIT
EN1 ;also from LRBLDEX2
+1 SET Y=$SELECT($DATA(^VA(200,Y,0)):$PIECE(^(0),"^",2),1:Y)
QUIT
+2 ;
HDR if LR("Q")
QUIT
IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRAA(1)," NO DONATIONS SINCE ",LRSTR
QUIT
H DO HDR
if LR("Q")
QUIT
WRITE !?10,"Donor (Reg #)",?42,"DOB",?48,"SEX",?52,"ABO/Rh",?59,"APHERESIS",?69,"PERM DEFER",!,LR("%")
QUIT
EN ;from LRBLDEX2
+1 DO H
if LR("Q")
QUIT
WRITE !,LRP," (Donor #: ",LRI,") <continued from page ",LRQ-1,">"
QUIT
H2 DO HDR
if LR("Q")
QUIT
WRITE !,"Donor ID",?15,"DONOR NAME",!,LR("%")
