LRBLDPA1 ;AVAMC/REG/CYM - BLOOD DONOR PRINT ;7/5/96 20:57 ;
;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
N LRDOB,NAME S (X,LRX)=^LRE(LR,0),PNM=$P(X,U),SEX=$P(X,U,2),LRABO=$P(X,U,5),LRRH=$P(X,U,6),SSN=$P(X,U,13),Y=$P(X,U,3) D D^LRU S LRDOB=Y,LRF=65.5,Z=.02,X=SEX D S S SEX=Y
D H S LR("F")=1 S X=$P(LRX,U,13) W:X]"" !,"SSN: ",X S X=$P(X,U,14) W:X]"" !,"MILITARY RANK: ",X
K ^TMP($J) S LRE=0 F LRJ=0:1 S LRE=$O(^LRE(LR,9,LRE)) Q:'LRE!(LR("Q")) S LRA=^(LRE,0) D:$Y>(IOSL-6) H Q:LR("Q") S X=LRA D ^DIWP
Q:LR("Q") D:LRJ ^DIWW Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q")
S X=$P(LRX,U,10),Z=.1 D S W ! W:X]"" "PERMANENT DEFERRAL: ",Y S X=+$P(LRX,U,12) D V W:X]"" ?29,"DEFERRAL ENTER/EDIT: ",X
S Y=$P(LRX,U,16) I Y D D^LRU W !,"PERMANENT DEFERRAL DATE CHANGE: ",Y
K ^TMP($J) S LRE=0 F LRJ=0:1 S LRE=$O(^LRE(LR,99,LRE)) Q:'LRE!(LR("Q")) S LRA=^(LRE,0) D:$Y>(IOSL-6) H Q:LR("Q") W:LRJ=0 !,"PERMANENT DEFERRAL REASON:" S X=LRA D ^DIWP
Q:LR("Q") D:LRJ ^DIWW Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q") D A^LRBLDPA2 Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q")
Q:LR("Q") K F S LRF=65.53,E=1,(F(1),G)="" F A=0:0 S A=$O(^LRE(LR,4,A)),Z=.01 Q:'A S X=$P(^LRE(LR,4,A,0),U) D S S F(E)=F(E)_Y_", ",G=G+1 I $L(F(E))>60 S F(E)=$P(F(E),", ",1,G-1),E=E+1,F(E)=Y_", ",G=""
I F(1)]"" W !!,"SCHEDULING/RECALL: " S X=F(1) D C^LRBLDPA2 I $D(F(2)) W !?19 S X=F(2) D C^LRBLDPA2
D:$Y>(IOSL-6) H Q:LR("Q") K F S E=1,(F(1))="" F A=0:0 S A=$O(^LRE(LR,2,A)) Q:'A S X=A D G S F(E)=X(3),E=E+1
I F(1)]"" W !,"GROUP AFFILIATION: " F E=0:0 S E=$O(F(E)) Q:'E!(LR("Q")) D:$Y>(IOSL-6) H1 Q:LR("Q") W:E>1 ! W ?19,F(E)
Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q") S LRF=65.5,X=$P(LRX,U,4),Z=.04 D S W !!?3,"APHERESIS: ",Y,?28,"CUMULATIVE DONATIONS: ",$P(LRX,U,7)
W !,"TOTAL AWARDS: ",$P(LRX,U,8),?34,"GIVE NEW AWARD: " S X=$S($D(^LRE(LR,3)):$P(^(3),U),1:"") I X]"" S Z=.085 D S W Y
S X=+$P(LRX,U,9) D V W !?2,"DEMOG EDIT: ",X S Y=$P(LRX,U,11) D D^LRU W ?45,"DATE REG/EDITED: ",Y
S X=$S($D(^LRE(LR,1)):^(1),1:"") W !!?3,"ADDRESS: ",$P(X,U)," ",$P(X,U,2) S Y=$P(X,U,3) W:Y]"" !?12,Y W !?12,$P(X,U,4),", " S Y=+$P(X,U,5) W $S($D(^DIC(5,Y,0)):$P(^(0),U),1:"")," ",$P(X,U,6)
D:$Y>(IOSL-6) H Q:LR("Q") W !,"HOME PHONE: ",$P(X,U,7),?38,"WORK PHONE: ",$P(X,U,8)
I $D(LRI) S A=LRI,LRF=65.54,LRX=^LRE(LR,5,LRI,0) D W D:LRN=1 ^LRBLDPAW Q
S A=0 F B=1:1 S A=$O(^LRE(LR,5,A)) Q:'A!(LR("Q")) S LRF=65.54,LRX=^(A,0) D:$Y>(IOSL-6) H Q:LR("Q") D W Q:LR("Q")
Q
W S Y=+LRX D D^LRU S LRY=Y D FIELD^DID(65.54,.01,"","LABEL","NAME") S NAME=NAME("LABEL") W !!,NAME,": ",Y
S Z=1,X=$P(LRX,U,2) D S W ?40,"DONATION CODE: ",Y S X=+$P(LRX,U,6) D G W !,"COLLECTION SITE: ",X S X=+$P(LRX,U,7) D G W ?40,"DONATION GROUP: ",$E(X,1,24)
S Y=$P(LRX,U,13) D D^LRU W !,"ARRIVAL/APPT TIME: ",Y,?40,"ENTER/EDIT: " S X=+$P(LRX,U,8) D V W X D M Q:LR("Q")
I $P(LRX,U,14) S X=$P(LRX,U,14),Z=.14 D S D FIELD^DID(65.54,.14,"","LABEL","NAME") S NAME=NAME("LABEL") W !,NAME,": ",Y
D M Q:LR("Q") S X=$P(LRX,U,11),Z=1.1 D S,FIELD^DID(65.54,1.1,"","LABEL","NAME") S NAME=NAME("LABEL") W !,NAME,": ",Y
S X=$P(LRX,U,12) I X D P^LRBLDPA2 D FIELD^DID(65.54,1.2,"","LABEL","NAME") S NAME=NAME("LABEL") W !,NAME,": ",$P(X,U)," ",$P(X,U,9)
S X=+$P(LRX,U,3) D G W ?40,"DONOR REACTION: ",X
S C=0 F E=1:1 S C=$O(^LRE(LR,5,A,1,C)) Q:'C!(LR("Q")) S LRA=^(C,0) D M Q:LR("Q") W:E=1 !,"DEFERRAL REASON:" S X=+LRA D G W:X]"" !?3,X(3)
D M Q:LR("Q") W:$P(LRX,U,4)]"" !,"UNIT ID: ",$P(LRX,U,4) S LRZ=$S($D(^LRE(LR,5,A,2)):^(2),1:"") Q:LRZ="" W ?40,"PRIMARY BAG: " S X=$P(LRZ,U,1),Z=4.1 D S W Y
S X=$P(LRZ,U,9),Z=4.11 D S W !,"ANTICOAGULANT: ",Y,?40,"BAG LOT #: ",$P(LRZ,U,10)
D ^LRBLDPA2 Q
G S X=$S($D(^LAB(65.4,X,0)):^(0),1:""),X(3)=$P(X,U,3),X=$P(X,U) Q
V S X=$S($D(^VA(200,X,0)):$P(^(0),U),1:"") Q
M S LRM=0 I $Y>(IOSL-6) D H S LRM=1
Q:LR("Q") W:LRM !,"DONATION OR DEFERRAL DATE: ",LRY Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !," BLOOD DONOR: ",PNM,?45,"DOB: ",LRDOB,!?9,"SEX: ",SEX,?42,"ABO/RH: ",LRABO," ",LRRH,!
Q
H1 D H Q:LR("Q") W !!,"GROUP AFFILIATION:" Q
;
S I X=":" S (X,Y)="" Q
S Y=$$EXTERNAL^DILFD(LRF,Z,"",X) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDPA1 4191 printed Dec 13, 2024@02:10:41 Page 2
LRBLDPA1 ;AVAMC/REG/CYM - BLOOD DONOR PRINT ;7/5/96 20:57 ;
+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 NEW LRDOB,NAME
SET (X,LRX)=^LRE(LR,0)
SET PNM=$PIECE(X,U)
SET SEX=$PIECE(X,U,2)
SET LRABO=$PIECE(X,U,5)
SET LRRH=$PIECE(X,U,6)
SET SSN=$PIECE(X,U,13)
SET Y=$PIECE(X,U,3)
DO D^LRU
SET LRDOB=Y
SET LRF=65.5
SET Z=.02
SET X=SEX
DO S
SET SEX=Y
+4 DO H
SET LR("F")=1
SET X=$PIECE(LRX,U,13)
if X]""
WRITE !,"SSN: ",X
SET X=$PIECE(X,U,14)
if X]""
WRITE !,"MILITARY RANK: ",X
+5 KILL ^TMP($JOB)
SET LRE=0
FOR LRJ=0:1
SET LRE=$ORDER(^LRE(LR,9,LRE))
if 'LRE!(LR("Q"))
QUIT
SET LRA=^(LRE,0)
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
SET X=LRA
DO ^DIWP
+6 if LR("Q")
QUIT
if LRJ
DO ^DIWW
if LR("Q")
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
+7 SET X=$PIECE(LRX,U,10)
SET Z=.1
DO S
WRITE !
if X]""
WRITE "PERMANENT DEFERRAL: ",Y
SET X=+$PIECE(LRX,U,12)
DO V
if X]""
WRITE ?29,"DEFERRAL ENTER/EDIT: ",X
+8 SET Y=$PIECE(LRX,U,16)
IF Y
DO D^LRU
WRITE !,"PERMANENT DEFERRAL DATE CHANGE: ",Y
+9 KILL ^TMP($JOB)
SET LRE=0
FOR LRJ=0:1
SET LRE=$ORDER(^LRE(LR,99,LRE))
if 'LRE!(LR("Q"))
QUIT
SET LRA=^(LRE,0)
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
if LRJ=0
WRITE !,"PERMANENT DEFERRAL REASON:"
SET X=LRA
DO ^DIWP
+10 if LR("Q")
QUIT
if LRJ
DO ^DIWW
if LR("Q")
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
DO A^LRBLDPA2
if LR("Q")
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
+11 if LR("Q")
QUIT
KILL F
SET LRF=65.53
SET E=1
SET (F(1),G)=""
FOR A=0:0
SET A=$ORDER(^LRE(LR,4,A))
SET Z=.01
if 'A
QUIT
SET X=$PIECE(^LRE(LR,4,A,0),U)
DO S
SET F(E)=F(E)_Y_", "
SET G=G+1
IF $LENGTH(F(E))>60
SET F(E)=$PIECE(F(E),", ",1,G-1)
SET E=E+1
SET F(E)=Y_", "
SET G=""
+12 IF F(1)]""
WRITE !!,"SCHEDULING/RECALL: "
SET X=F(1)
DO C^LRBLDPA2
IF $DATA(F(2))
WRITE !?19
SET X=F(2)
DO C^LRBLDPA2
+13 if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
KILL F
SET E=1
SET (F(1))=""
FOR A=0:0
SET A=$ORDER(^LRE(LR,2,A))
if 'A
QUIT
SET X=A
DO G
SET F(E)=X(3)
SET E=E+1
+14 IF F(1)]""
WRITE !,"GROUP AFFILIATION: "
FOR E=0:0
SET E=$ORDER(F(E))
if 'E!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
if E>1
WRITE !
WRITE ?19,F(E)
+15 if LR("Q")
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
SET LRF=65.5
SET X=$PIECE(LRX,U,4)
SET Z=.04
DO S
WRITE !!?3,"APHERESIS: ",Y,?28,"CUMULATIVE DONATIONS: ",$PIECE(LRX,U,7)
+16 WRITE !,"TOTAL AWARDS: ",$PIECE(LRX,U,8),?34,"GIVE NEW AWARD: "
SET X=$SELECT($DATA(^LRE(LR,3)):$PIECE(^(3),U),1:"")
IF X]""
SET Z=.085
DO S
WRITE Y
+17 SET X=+$PIECE(LRX,U,9)
DO V
WRITE !?2,"DEMOG EDIT: ",X
SET Y=$PIECE(LRX,U,11)
DO D^LRU
WRITE ?45,"DATE REG/EDITED: ",Y
+18 SET X=$SELECT($DATA(^LRE(LR,1)):^(1),1:"")
WRITE !!?3,"ADDRESS: ",$PIECE(X,U)," ",$PIECE(X,U,2)
SET Y=$PIECE(X,U,3)
if Y]""
WRITE !?12,Y
WRITE !?12,$PIECE(X,U,4),", "
SET Y=+$PIECE(X,U,5)
WRITE $SELECT($DATA(^DIC(5,Y,0)):$PIECE(^(0),U),1:"")," ",$PIECE(X,U,6)
+19 if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,"HOME PHONE: ",$PIECE(X,U,7),?38,"WORK PHONE: ",$PIECE(X,U,8)
+20 IF $DATA(LRI)
SET A=LRI
SET LRF=65.54
SET LRX=^LRE(LR,5,LRI,0)
DO W
if LRN=1
DO ^LRBLDPAW
QUIT
+21 SET A=0
FOR B=1:1
SET A=$ORDER(^LRE(LR,5,A))
if 'A!(LR("Q"))
QUIT
SET LRF=65.54
SET LRX=^(A,0)
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
DO W
if LR("Q")
QUIT
+22 QUIT
W SET Y=+LRX
DO D^LRU
SET LRY=Y
DO FIELD^DID(65.54,.01,"","LABEL","NAME")
SET NAME=NAME("LABEL")
WRITE !!,NAME,": ",Y
+1 SET Z=1
SET X=$PIECE(LRX,U,2)
DO S
WRITE ?40,"DONATION CODE: ",Y
SET X=+$PIECE(LRX,U,6)
DO G
WRITE !,"COLLECTION SITE: ",X
SET X=+$PIECE(LRX,U,7)
DO G
WRITE ?40,"DONATION GROUP: ",$EXTRACT(X,1,24)
+2 SET Y=$PIECE(LRX,U,13)
DO D^LRU
WRITE !,"ARRIVAL/APPT TIME: ",Y,?40,"ENTER/EDIT: "
SET X=+$PIECE(LRX,U,8)
DO V
WRITE X
DO M
if LR("Q")
QUIT
+3 IF $PIECE(LRX,U,14)
SET X=$PIECE(LRX,U,14)
SET Z=.14
DO S
DO FIELD^DID(65.54,.14,"","LABEL","NAME")
SET NAME=NAME("LABEL")
WRITE !,NAME,": ",Y
+4 DO M
if LR("Q")
QUIT
SET X=$PIECE(LRX,U,11)
SET Z=1.1
DO S
DO FIELD^DID(65.54,1.1,"","LABEL","NAME")
SET NAME=NAME("LABEL")
WRITE !,NAME,": ",Y
+5 SET X=$PIECE(LRX,U,12)
IF X
DO P^LRBLDPA2
DO FIELD^DID(65.54,1.2,"","LABEL","NAME")
SET NAME=NAME("LABEL")
WRITE !,NAME,": ",$PIECE(X,U)," ",$PIECE(X,U,9)
+6 SET X=+$PIECE(LRX,U,3)
DO G
WRITE ?40,"DONOR REACTION: ",X
+7 SET C=0
FOR E=1:1
SET C=$ORDER(^LRE(LR,5,A,1,C))
if 'C!(LR("Q"))
QUIT
SET LRA=^(C,0)
DO M
if LR("Q")
QUIT
if E=1
WRITE !,"DEFERRAL REASON:"
SET X=+LRA
DO G
if X]""
WRITE !?3,X(3)
+8 DO M
if LR("Q")
QUIT
if $PIECE(LRX,U,4)]""
WRITE !,"UNIT ID: ",$PIECE(LRX,U,4)
SET LRZ=$SELECT($DATA(^LRE(LR,5,A,2)):^(2),1:"")
if LRZ=""
QUIT
WRITE ?40,"PRIMARY BAG: "
SET X=$PIECE(LRZ,U,1)
SET Z=4.1
DO S
WRITE Y
+9 SET X=$PIECE(LRZ,U,9)
SET Z=4.11
DO S
WRITE !,"ANTICOAGULANT: ",Y,?40,"BAG LOT #: ",$PIECE(LRZ,U,10)
+10 DO ^LRBLDPA2
QUIT
G SET X=$SELECT($DATA(^LAB(65.4,X,0)):^(0),1:"")
SET X(3)=$PIECE(X,U,3)
SET X=$PIECE(X,U)
QUIT
V SET X=$SELECT($DATA(^VA(200,X,0)):$PIECE(^(0),U),1:"")
QUIT
M SET LRM=0
IF $Y>(IOSL-6)
DO H
SET LRM=1
+1 if LR("Q")
QUIT
if LRM
WRITE !,"DONATION OR DEFERRAL DATE: ",LRY
QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !," BLOOD DONOR: ",PNM,?45,"DOB: ",LRDOB,!?9,"SEX: ",SEX,?42,"ABO/RH: ",LRABO," ",LRRH,!
+2 QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !!,"GROUP AFFILIATION:"
QUIT
+1 ;
S IF X=":"
SET (X,Y)=""
QUIT
+1 SET Y=$$EXTERNAL^DILFD(LRF,Z,"",X)
QUIT
