- 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 Mar 13, 2025@21:15:02 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
