- LRBLDR ;AVAMC/REG/CYM - DONOR REGISTRATION FORM 6/28/96 12:53 ;
- ;;5.2;LAB SERVICE;**72,247,408**;Sep 27, 1994;Build 8
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- Q D END S LRAA=$O(^LRO(68,"B","BLOOD BANK",0)),LRB=$O(^LAB(65.4,"B","DNRHX",0)) I 'LRAA W $C(7),!!,"ENTER ""BLOOD BANK"" IN ACCESSION AREA FILE",!! G END
- I 'LRB W $C(7),!!,"ENTER ""DNRHX"" (BLOOD DONOR HISTORY QUESTIONS) IN BLOOD BANK UTILITY FILE",!! G END
- S:'$D(^LRO(69.2,LRAA,5,0)) ^(0)="^69.24A^0^0" S IOP="HOME" D ^%ZIS
- W !!?20,"Donor registration forms",!!
- I $O(^LRO(69.2,LRAA,5,0)) W "Display list of donors for printing registration forms " S %=2 D YN^LRU G:%<1&(%Y'="@") END D S^LRBLDR1:%=1,D^LRBLDR1:%Y="@"
- W !!,"Add all donors from a GROUP AFFILIATION: " S %=2 D YN^LRU G:%<1 END D:%=1 A^LRBLDR1
- DNR S DIC="^LRE(",DIC(0)="AEQM",D="B^C^"_$S("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D"),DIC("A")="Add Donor Name to list: " D MIX^DIC1 K DIC I Y>0 S ^LRO(69.2,LRAA,5,+Y,0)=+Y_"^65.5^"_$P(Y,U,2),^LRO(69.2,LRAA,5,"C",$P(Y,U,2),+Y)="" G DNR
- I $O(^LRO(69.2,LRAA,5,0))'>0 W $C(7),!!,"No list for printing donor registration forms !",!! G END
- W !!,"Print donor registration forms " S %=2 D YN^LRU G:%'=1 END
- S DIC="^LAB(65.4,",DIC(0)="AEQMZ",DIC("A")="Select COLLECTION SITE to appear on form: ",DIC("S")="I $P(^(0),U,2)[""C""" D ^DIC K DIC G:X[U!(X="") END S S=$P(Y(0),U,3)
- S X="T",%DT="" D ^%DT S LRD=Y D D^LRU S T=Y,%DT="AEQ",%DT("A")="Date to appear on form: ",%DT("B")=T D ^%DT K %DT G:Y<1 END D D^LRU S T=Y
- S ZTRTN="QUE^LRBLDR" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO D L^LRU,S^LRU S DIWR=IOM-5,DIWL=5,DIWF="W" D FIELD^DID(65.54,1,"","POINTER","LRF") S LRF=LRF("POINTER"),Y=$O(^LAB(65.4,"B","DNRCX",0)) I Y S LRC=0 F X=0:0 S X=$O(^LAB(65.4,Y,3,X)) Q:'X S J(X)=^(X,0),LRC=LRC+1
- S LRC=LRC+6,C=0 F B=0:0 S C=$O(^LRO(69.2,LRAA,5,"C",C)) Q:C=""!(LR("Q")) F W=0:0 S W=$O(^LRO(69.2,LRAA,5,"C",C,W)) Q:'W K A,Z S LRQ=0 D PRT
- K ^LRO(69.2,LRAA,5) S ^LRO(69.2,LRAA,5,0)="^69.24A^0^0" W:IOST'?1"C".E @IOF D END^LRUTL,END Q
- PRT I '$D(^LRE(W,0)) K ^LRO(69.2,LRAA,5,"C",C,W),^LRO(69.2,LRAA,5,W) Q
- S Z=^LRE(W,0),N=$P(Z,"^"),SEX=$P(Z,"^",2),DOB=$P(Z,"^",3),E=$P(Z,"^",5),F=$P(Z,"^",6),M=$P(Z,"^",7),R=$P(Z,"^",4),G=$P(Z,"^",10),G(16)=$P(Z,"^",16),SSN=$P(Z,"^",13),Y=DOB D D^LRU S DOB=Y S:DOB[1700 DOB="" D:SSN]"" SSN^LRU
- S Z=$S($D(^LRE(W,1)):^(1),1:""),Z(5)="" S:$P(Z,"^",5) Z(5)=$S($D(^DIC(5,$P(Z,"^",5),0)):$P(^(0),"^"),1:"")
- S A(1)=$P(Z,"^"),A(2)=$P(Z,"^",2),A(3)=$P(Z,"^",3),A(4)=$P(Z,"^",4),A(6)=$P(Z,"^",6),A(7)=$P(Z,"^",7),A(8)=$P(Z,"^",8)
- S X=$O(^LRE(W,5,0)),(LR(65.54,.01),LR(65.54,1))="" I X S:+^(X,0)=LRD X=$O(^LRE(W,5,X)) I X S X=^LRE(W,5,X,0),Y=$P($P(X,"^"),".") D D^LRU S LR(65.54,.01)=Y,X=$P(X,"^",2) I X]"" S X=X_":",X=$P($P(LRF,X,2),";")
- S LR(65.54,1)=X D H S LR("F")=1 W !!,"DONOR HISTORY" K ^TMP($J)
- S K=0 F LRZ=0:1 S K=$O(^LAB(65.4,LRB,2,K)) Q:'K!(LR("Q")) S LRX=^(K,0) D:$Y>(IOSL-6) H1 Q:LR("Q") S X=LRX D ^DIWP
- Q:LR("Q") D:LRZ ^DIWW
- D C Q:LR("Q") W !!,"Date ..................at .....(time)",?40 F X=1:1:39 W "."
- W !?50,"(Donor)",!!?40 F X=1:1:39 W "."
- W !?50,"(Witness)" D H Q:LR("Q") D ^LRBLDR1 Q
- ;
- C W ! D:$Y>(IOSL-LRC) H1 Q:LR("Q") K ^TMP($J) S K=0 F LRZ=0:1 S K=$O(J(K)) Q:'K D:$Y>(IOSL-6) H Q:LR("Q") S X=J(K) D ^DIWP
- Q:LR("Q") D:LRZ ^DIWW Q
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"DONOR REGISTRATION",?60,"Date: ",T,!,"Collection site: ",S,!,LR("%")
- W !,N,?31,"Sex: ",SEX,?38,"DOB: ",DOB W ?60,"ABO: ",E," Rh: ",F
- I SSN]"" W !,"SSN: ",SSN
- W !,A(1)," ",A(2)," ",A(3),!,A(4),", ",Z(5)," ",A(6),!,"Home phone: ",A(7)," Business phone: ",A(8)
- W !,"Employer/Donor Group(s):",?36,"Current donation type:" F X=0:0 S X=$O(^LRE(W,2,X)) Q:'X S Y=^(X,0) W !?4,$S($D(^LAB(65.4,Y,0)):$P(^(0),"^",3),1:"")
- W !,"Cum donations: ",M,?20,"Previous visit: ",LR(65.54,.01) I LR(65.54,1)]"" W " (",LR(65.54,1) W:LR(65.54,1)'["DONATION" " DONATION" W ")"
- Q
- H1 D H Q:LR("Q") W !!,"Donor History (continued from pg ",LRQ-1,")" Q
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDR 4069 printed Feb 18, 2025@23:36:42 Page 2
- LRBLDR ;AVAMC/REG/CYM - DONOR REGISTRATION FORM 6/28/96 12:53 ;
- +1 ;;5.2;LAB SERVICE;**72,247,408**;Sep 27, 1994;Build 8
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 QUIT
- DO END
- SET LRAA=$ORDER(^LRO(68,"B","BLOOD BANK",0))
- SET LRB=$ORDER(^LAB(65.4,"B","DNRHX",0))
- IF 'LRAA
- WRITE $CHAR(7),!!,"ENTER ""BLOOD BANK"" IN ACCESSION AREA FILE",!!
- GOTO END
- +4 IF 'LRB
- WRITE $CHAR(7),!!,"ENTER ""DNRHX"" (BLOOD DONOR HISTORY QUESTIONS) IN BLOOD BANK UTILITY FILE",!!
- GOTO END
- +5 if '$DATA(^LRO(69.2,LRAA,5,0))
- SET ^(0)="^69.24A^0^0"
- SET IOP="HOME"
- DO ^%ZIS
- +6 WRITE !!?20,"Donor registration forms",!!
- +7 IF $ORDER(^LRO(69.2,LRAA,5,0))
- WRITE "Display list of donors for printing registration forms "
- SET %=2
- DO YN^LRU
- if %<1&(%Y'="@")
- GOTO END
- if %=1
- DO S^LRBLDR1
- if %Y="@"
- DO D^LRBLDR1
- +8 WRITE !!,"Add all donors from a GROUP AFFILIATION: "
- SET %=2
- DO YN^LRU
- if %<1
- GOTO END
- if %=1
- DO A^LRBLDR1
- DNR SET DIC="^LRE("
- SET DIC(0)="AEQM"
- SET D="B^C^"_$SELECT("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D")
- SET DIC("A")="Add Donor Name to list: "
- DO MIX^DIC1
- KILL DIC
- IF Y>0
- SET ^LRO(69.2,LRAA,5,+Y,0)=+Y_"^65.5^"_$PIECE(Y,U,2)
- SET ^LRO(69.2,LRAA,5,"C",$PIECE(Y,U,2),+Y)=""
- GOTO DNR
- +1 IF $ORDER(^LRO(69.2,LRAA,5,0))'>0
- WRITE $CHAR(7),!!,"No list for printing donor registration forms !",!!
- GOTO END
- +2 WRITE !!,"Print donor registration forms "
- SET %=2
- DO YN^LRU
- if %'=1
- GOTO END
- +3 SET DIC="^LAB(65.4,"
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Select COLLECTION SITE to appear on form: "
- SET DIC("S")="I $P(^(0),U,2)[""C"""
- DO ^DIC
- KILL DIC
- if X[U!(X="")
- GOTO END
- SET S=$PIECE(Y(0),U,3)
- +4 SET X="T"
- SET %DT=""
- DO ^%DT
- SET LRD=Y
- DO D^LRU
- SET T=Y
- SET %DT="AEQ"
- SET %DT("A")="Date to appear on form: "
- SET %DT("B")=T
- DO ^%DT
- KILL %DT
- if Y<1
- GOTO END
- DO D^LRU
- SET T=Y
- +5 SET ZTRTN="QUE^LRBLDR"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- DO L^LRU
- DO S^LRU
- SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF="W"
- DO FIELD^DID(65.54,1,"","POINTER","LRF")
- SET LRF=LRF("POINTER")
- SET Y=$ORDER(^LAB(65.4,"B","DNRCX",0))
- IF Y
- SET LRC=0
- FOR X=0:0
- SET X=$ORDER(^LAB(65.4,Y,3,X))
- if 'X
- QUIT
- SET J(X)=^(X,0)
- SET LRC=LRC+1
- +1 SET LRC=LRC+6
- SET C=0
- FOR B=0:0
- SET C=$ORDER(^LRO(69.2,LRAA,5,"C",C))
- if C=""!(LR("Q"))
- QUIT
- FOR W=0:0
- SET W=$ORDER(^LRO(69.2,LRAA,5,"C",C,W))
- if 'W
- QUIT
- KILL A,Z
- SET LRQ=0
- DO PRT
- +2 KILL ^LRO(69.2,LRAA,5)
- SET ^LRO(69.2,LRAA,5,0)="^69.24A^0^0"
- if IOST'?1"C".E
- WRITE @IOF
- DO END^LRUTL
- DO END
- QUIT
- PRT IF '$DATA(^LRE(W,0))
- KILL ^LRO(69.2,LRAA,5,"C",C,W),^LRO(69.2,LRAA,5,W)
- QUIT
- +1 SET Z=^LRE(W,0)
- SET N=$PIECE(Z,"^")
- SET SEX=$PIECE(Z,"^",2)
- SET DOB=$PIECE(Z,"^",3)
- SET E=$PIECE(Z,"^",5)
- SET F=$PIECE(Z,"^",6)
- SET M=$PIECE(Z,"^",7)
- SET R=$PIECE(Z,"^",4)
- SET G=$PIECE(Z,"^",10)
- SET G(16)=$PIECE(Z,"^",16)
- SET SSN=$PIECE(Z,"^",13)
- SET Y=DOB
- DO D^LRU
- SET DOB=Y
- if DOB[1700
- SET DOB=""
- if SSN]""
- DO SSN^LRU
- +2 SET Z=$SELECT($DATA(^LRE(W,1)):^(1),1:"")
- SET Z(5)=""
- if $PIECE(Z,"^",5)
- SET Z(5)=$SELECT($DATA(^DIC(5,$PIECE(Z,"^",5),0)):$PIECE(^(0),"^"),1:"")
- +3 SET A(1)=$PIECE(Z,"^")
- SET A(2)=$PIECE(Z,"^",2)
- SET A(3)=$PIECE(Z,"^",3)
- SET A(4)=$PIECE(Z,"^",4)
- SET A(6)=$PIECE(Z,"^",6)
- SET A(7)=$PIECE(Z,"^",7)
- SET A(8)=$PIECE(Z,"^",8)
- +4 SET X=$ORDER(^LRE(W,5,0))
- SET (LR(65.54,.01),LR(65.54,1))=""
- IF X
- if +^(X,0)=LRD
- SET X=$ORDER(^LRE(W,5,X))
- IF X
- SET X=^LRE(W,5,X,0)
- SET Y=$PIECE($PIECE(X,"^"),".")
- DO D^LRU
- SET LR(65.54,.01)=Y
- SET X=$PIECE(X,"^",2)
- IF X]""
- SET X=X_":"
- SET X=$PIECE($PIECE(LRF,X,2),";")
- +5 SET LR(65.54,1)=X
- DO H
- SET LR("F")=1
- WRITE !!,"DONOR HISTORY"
- KILL ^TMP($JOB)
- +6 SET K=0
- FOR LRZ=0:1
- SET K=$ORDER(^LAB(65.4,LRB,2,K))
- if 'K!(LR("Q"))
- QUIT
- SET LRX=^(K,0)
- if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- SET X=LRX
- DO ^DIWP
- +7 if LR("Q")
- QUIT
- if LRZ
- DO ^DIWW
- +8 DO C
- if LR("Q")
- QUIT
- WRITE !!,"Date ..................at .....(time)",?40
- FOR X=1:1:39
- WRITE "."
- +9 WRITE !?50,"(Donor)",!!?40
- FOR X=1:1:39
- WRITE "."
- +10 WRITE !?50,"(Witness)"
- DO H
- if LR("Q")
- QUIT
- DO ^LRBLDR1
- QUIT
- +11 ;
- C WRITE !
- if $Y>(IOSL-LRC)
- DO H1
- if LR("Q")
- QUIT
- KILL ^TMP($JOB)
- SET K=0
- FOR LRZ=0:1
- SET K=$ORDER(J(K))
- if 'K
- QUIT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- SET X=J(K)
- DO ^DIWP
- +1 if LR("Q")
- QUIT
- if LRZ
- DO ^DIWW
- QUIT
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"DONOR REGISTRATION",?60,"Date: ",T,!,"Collection site: ",S,!,LR("%")
- +2 WRITE !,N,?31,"Sex: ",SEX,?38,"DOB: ",DOB
- WRITE ?60,"ABO: ",E," Rh: ",F
- +3 IF SSN]""
- WRITE !,"SSN: ",SSN
- +4 WRITE !,A(1)," ",A(2)," ",A(3),!,A(4),", ",Z(5)," ",A(6),!,"Home phone: ",A(7)," Business phone: ",A(8)
- +5 WRITE !,"Employer/Donor Group(s):",?36,"Current donation type:"
- FOR X=0:0
- SET X=$ORDER(^LRE(W,2,X))
- if 'X
- QUIT
- SET Y=^(X,0)
- WRITE !?4,$SELECT($DATA(^LAB(65.4,Y,0)):$PIECE(^(0),"^",3),1:"")
- +6 WRITE !,"Cum donations: ",M,?20,"Previous visit: ",LR(65.54,.01)
- IF LR(65.54,1)]""
- WRITE " (",LR(65.54,1)
- if LR(65.54,1)'["DONATION"
- WRITE " DONATION"
- WRITE ")"
- +7 QUIT
- H1 DO H
- if LR("Q")
- QUIT
- WRITE !!,"Donor History (continued from pg ",LRQ-1,")"
- QUIT
- +1 ;
- END DO V^LRU
- QUIT