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 Oct 16, 2024@18:11:34 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
