- 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 Feb 18, 2025@23:36:26 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("%")