- LRBLDLG ;AVAMC/REG/CYM - BB DONOR LOG-IN ;1/29/97 12:48 ;
- ;;5.2;LAB SERVICE;**90,247,408**;Sep 27, 1994;Build 8
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- Q D V^LRU S LR("SSN")=$P($G(^LAB(69.9,1,8,1,0)),U,5),LR("LRBLDLG")="",X="BLOOD BANK" D ^LRUTL G:Y=-1 END D EN1^LRBLY,D^LRBLU G:'$D(X) END
- W @IOF,?30,"Log-in donor visits",! I LRCAPA D Z^LRBLWD G:$D(LRX) END
- S %DT="AEX",%DT(0)="-N",%DT("A")="Enter DONATION DATE: TODAY// " D ^%DT K %DT I X="" S Y=DT W LRH(0)
- G:Y<1 END S (LRAD,X)=Y,LRI=9999999-Y D DW^%DTC W " ",X S:'$D(^LRO(69.2,LRAA,5,0)) ^(0)="^69.24A^0^0"
- W !!,"For a group of donors COLLECTION SITE & DONATION GROUP need be entered once.",!,"If not desired just press 'RETURN' key after the following two prompts.",!!
- S DIC=65.4,DIC("S")="I $P(^(0),U,2)[""C""",DIC("A")="Enter COLLECTION SITE: ",DIC(0)="AEQM" D ^DIC K DIC G:X[U END S LR=$S(Y=-1:"",1:+Y)
- S DIC=65.4,DIC(0)="AEQM",DIC("A")="Enter DONATION GROUP: ",DIC("S")="I $P(^(0),U,2)[""G""" D ^DIC K DIC G:X[U END S LR(1)=$S(Y=-1:"",1:+Y)
- DNR K LRC,DIC,DIE,DR,DA,LR("CK")
- W !! S (DIC,DIE)="^LRE(",DIC(0)="AEQLMZ",DLAYGO=65,D="B^C^"_$S("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D") D MIX^DIC1 K DIC,DLAYGO G:Y<1 END
- S (LRQ,DA)=+Y,(LRP,LRP(0))=$P(Y,U,2) I $P(Y,U,3) D ^LRBLD G:'$D(DA) DNR D ADD G OK
- S B=0 I $D(^LRE(DA,9)) S DIWR=IOM-5,DIWL=5,DIWF="W" S A=0 F B=0:1 S A=$O(^LRE(DA,9,A)) Q:'A W:'B ! S X=^(A,0) D ^DIWP
- D:B ^DIWW W !,"Is this the Donor " S %=1 D YN^LRU G:%'=1 DNR
- OK G:'$D(^LRE(LRQ,0)) DNR S X=^(0),X1=DT,(X2,LRD)=$P(X,"^",3),LRB=$E(X2,4,5)_"-"_$E(X2,6,7)_"-"_$E(X2,2,3),LRS(2)=$P(X,"^",13) D ^%DTC S X=X\365.25
- I X<18 W $C(7),!!,"Age:",X," Does donor have permission to donate " S %=1 D YN^LRU G:%'=1 DNR
- I X>64 W $C(7)," Age: ",X,!?7,"Does donor have physician permission to donate " S %=1 D YN^LRU G:%'=1 DNR
- W @IOF S (DIE,DIC)="^LRE(",DA=LRQ,DR="0;1;2;4" D EN^DIQ
- I $P(^LRE(LRQ,0),U,10) W $C(7),!!,$P(^(0),U)," permanently deferred except for autologous",!,"or therapeutic donation. If any questions see physician in charge.",!!,"Do you want autologous/therapeutic donation " S %=2 D YN^LRU G:%'=1 DNR
- I LR("SSN"),$P(^LRE(LRQ,0),U,13)="" S DA=LRQ,DR=.13,DIE="^LRE(" D ^DIE
- W !,"EDIT above information: " S %=2 D YN^LRU G:%<1 DNR I %=1 K DR D CK^LRU G:$D(LR("CK")) DNR S DR="[LRBLDEMO]" D ^DIE D FRE^LRU G OK
- S X=$O(^LRE(LRQ,5,0)) I X S Y=+^(X,0) D D^LRU W " Last visit: ",Y
- S:'$D(^LRE(LRQ,5,0)) ^(0)="^65.54DA^^" I '$D(^(LRI,0)) L +^LRE(LRQ,5) S X=$P(^LRE(LRQ,5,0),"^",4),^(0)="^65.54DA^"_LRI_"^"_(X+1),^(LRI,0)=LRAD_"^^^^^"_LR_"^"_LR(1),^LRE("AD",$P(LRAD,"."),LRQ)="" L -^LRE(LRQ,5)
- S (LR(65.54,1),LR(65.54,1.1),LRA)="",DA=LRI,DA(1)=LRQ,DIE="^LRE(LRQ,5,"
- A S DR=".02;.03;.13//^S X=""NOW"";1//^S X=""WHOLE BLOOD"";S LR(65.54,1)=X;S:X=""N"" Y=2;1.1//^S X=""HOMOLOGOUS"";S LR(65.54,1.1)=X;S:X=""A"" LRA=LRP;S LRT=X;S:""AD""'[X Y=0;W !!;1.2//^S X=LRA;S Y=0;2"
- D ^DIE I $D(Y) G:$P(^LRE(LRQ,5,LRI,0),U,4)]"" DNR W $C(7),!!,"Delete all data from this donation " S %=2 D YN^LRU G:%'=1 A S DA=LRI,DIK="^LRE(LRQ,5," D ^DIK K DIK G DNR
- I LR(65.54,1.1)="A",'$P(^LRE(LRQ,5,LRI,0),U,12) W $C(7),!!,"Autologous donation and RESTRICTED FOR: field not entered.",!,"Delete all data from this donation " S %=2 D YN^LRU G:%'=1 A S DA=LRI,DIK="^LRE(LRQ,5," D ^DIK K DIK G DNR
- I LR(65.54,1)="N" D EN^LRBLY D:LRCAPA N^LRBLWD G DNR
- S LR(65.54)=LR(65.54,1.1)_LR(65.54,1),X1=9999999-LRI,X2=-55 D C^%DTC S Z(1)=9999999-X
- F X=LRI:0 S X=$O(^LRE(LRQ,5,X)) Q:'X!(X>Z(1)) S Y=$P(^(X,0),"^",2) I LR(65.54,1)="W",LR(65.54,1.1)="H",Y="W" W !!,"LAST WHOLE BLOOD DONATION " S LRC=1,(Y,Z)=+^(0) D D^LRU W Y Q
- I $D(LRC) S X1=LRAD,X2=Z D ^%DTC I X<56 W $C(7),!!,"SORRY NOT 8 WEEKS SINCE LAST DONATION OF WHOLE BLOOD" S X1=Z,X2=56 D C^%DTC S Y=X D D^LRU W !,"COME BACK ON OR AFTER ",Y D RES D:LRCAPA N^LRBLWD G DNR
- I LRCAPA D @(LR(65.54)_"^LRBLWD")
- D EN^LRBLY W !,"Enter donor in list for printing registration form " S %=2 D YN^LRU G:%'=1 MORE
- S ^LRO(69.2,LRAA,5,LRQ,0)=LRQ_"^65.5^"_LRP,^LRO(69.2,LRAA,5,"C",LRP,LRQ)="" G DNR
- MORE W !!,"Continue to enter collection information " S %=1 D YN^LRU G:%'=1 DNR
- K DA,DR,DIE,DIC,DR,DQ S (DIC,DIE)="^LRE(",DA=LRQ,DR="[LRBLDCPN]" D ^DIE G DNR
- ADD S DR=$S(LRH(2):"[LRBLDNEWM]",1:"[LRBLDNEW]") D ^DIE Q
- RES S X=^LRE(LRQ,5,LRI,0),^(0)=$P(X,"^")_"^"_"N"_"^"_$P(X,"^",3,99) Q
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDLG 4398 printed Feb 18, 2025@23:36:30 Page 2
- LRBLDLG ;AVAMC/REG/CYM - BB DONOR LOG-IN ;1/29/97 12:48 ;
- +1 ;;5.2;LAB SERVICE;**90,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 V^LRU
- SET LR("SSN")=$PIECE($GET(^LAB(69.9,1,8,1,0)),U,5)
- SET LR("LRBLDLG")=""
- SET X="BLOOD BANK"
- DO ^LRUTL
- if Y=-1
- GOTO END
- DO EN1^LRBLY
- DO D^LRBLU
- if '$DATA(X)
- GOTO END
- +4 WRITE @IOF,?30,"Log-in donor visits",!
- IF LRCAPA
- DO Z^LRBLWD
- if $DATA(LRX)
- GOTO END
- +5 SET %DT="AEX"
- SET %DT(0)="-N"
- SET %DT("A")="Enter DONATION DATE: TODAY// "
- DO ^%DT
- KILL %DT
- IF X=""
- SET Y=DT
- WRITE LRH(0)
- +6 if Y<1
- GOTO END
- SET (LRAD,X)=Y
- SET LRI=9999999-Y
- DO DW^%DTC
- WRITE " ",X
- if '$DATA(^LRO(69.2,LRAA,5,0))
- SET ^(0)="^69.24A^0^0"
- +7 WRITE !!,"For a group of donors COLLECTION SITE & DONATION GROUP need be entered once.",!,"If not desired just press 'RETURN' key after the following two prompts.",!!
- +8 SET DIC=65.4
- SET DIC("S")="I $P(^(0),U,2)[""C"""
- SET DIC("A")="Enter COLLECTION SITE: "
- SET DIC(0)="AEQM"
- DO ^DIC
- KILL DIC
- if X[U
- GOTO END
- SET LR=$SELECT(Y=-1:"",1:+Y)
- +9 SET DIC=65.4
- SET DIC(0)="AEQM"
- SET DIC("A")="Enter DONATION GROUP: "
- SET DIC("S")="I $P(^(0),U,2)[""G"""
- DO ^DIC
- KILL DIC
- if X[U
- GOTO END
- SET LR(1)=$SELECT(Y=-1:"",1:+Y)
- DNR KILL LRC,DIC,DIE,DR,DA,LR("CK")
- +1 WRITE !!
- SET (DIC,DIE)="^LRE("
- SET DIC(0)="AEQLMZ"
- SET DLAYGO=65
- SET D="B^C^"_$SELECT("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D")
- DO MIX^DIC1
- KILL DIC,DLAYGO
- if Y<1
- GOTO END
- +2 SET (LRQ,DA)=+Y
- SET (LRP,LRP(0))=$PIECE(Y,U,2)
- IF $PIECE(Y,U,3)
- DO ^LRBLD
- if '$DATA(DA)
- GOTO DNR
- DO ADD
- GOTO OK
- +3 SET B=0
- IF $DATA(^LRE(DA,9))
- SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF="W"
- SET A=0
- FOR B=0:1
- SET A=$ORDER(^LRE(DA,9,A))
- if 'A
- QUIT
- if 'B
- WRITE !
- SET X=^(A,0)
- DO ^DIWP
- +4 if B
- DO ^DIWW
- WRITE !,"Is this the Donor "
- SET %=1
- DO YN^LRU
- if %'=1
- GOTO DNR
- OK if '$DATA(^LRE(LRQ,0))
- GOTO DNR
- SET X=^(0)
- SET X1=DT
- SET (X2,LRD)=$PIECE(X,"^",3)
- SET LRB=$EXTRACT(X2,4,5)_"-"_$EXTRACT(X2,6,7)_"-"_$EXTRACT(X2,2,3)
- SET LRS(2)=$PIECE(X,"^",13)
- DO ^%DTC
- SET X=X\365.25
- +1 IF X<18
- WRITE $CHAR(7),!!,"Age:",X," Does donor have permission to donate "
- SET %=1
- DO YN^LRU
- if %'=1
- GOTO DNR
- +2 IF X>64
- WRITE $CHAR(7)," Age: ",X,!?7,"Does donor have physician permission to donate "
- SET %=1
- DO YN^LRU
- if %'=1
- GOTO DNR
- +3 WRITE @IOF
- SET (DIE,DIC)="^LRE("
- SET DA=LRQ
- SET DR="0;1;2;4"
- DO EN^DIQ
- +4 IF $PIECE(^LRE(LRQ,0),U,10)
- WRITE $CHAR(7),!!,$PIECE(^(0),U)," permanently deferred except for autologous",!,"or therapeutic donation. If any questions see physician in charge.",!!,"Do you want autologous/therapeutic donation "
- SET %=2
- DO YN^LRU
- if %'=1
- GOTO DNR
- +5 IF LR("SSN")
- IF $PIECE(^LRE(LRQ,0),U,13)=""
- SET DA=LRQ
- SET DR=.13
- SET DIE="^LRE("
- DO ^DIE
- +6 WRITE !,"EDIT above information: "
- SET %=2
- DO YN^LRU
- if %<1
- GOTO DNR
- IF %=1
- KILL DR
- DO CK^LRU
- if $DATA(LR("CK"))
- GOTO DNR
- SET DR="[LRBLDEMO]"
- DO ^DIE
- DO FRE^LRU
- GOTO OK
- +7 SET X=$ORDER(^LRE(LRQ,5,0))
- IF X
- SET Y=+^(X,0)
- DO D^LRU
- WRITE " Last visit: ",Y
- +8 if '$DATA(^LRE(LRQ,5,0))
- SET ^(0)="^65.54DA^^"
- IF '$DATA(^(LRI,0))
- LOCK +^LRE(LRQ,5)
- SET X=$PIECE(^LRE(LRQ,5,0),"^",4)
- SET ^(0)="^65.54DA^"_LRI_"^"_(X+1)
- SET ^(LRI,0)=LRAD_"^^^^^"_LR_"^"_LR(1)
- SET ^LRE("AD",$PIECE(LRAD,"."),LRQ)=""
- LOCK -^LRE(LRQ,5)
- +9 SET (LR(65.54,1),LR(65.54,1.1),LRA)=""
- SET DA=LRI
- SET DA(1)=LRQ
- SET DIE="^LRE(LRQ,5,"
- A SET DR=".02;.03;.13//^S X=""NOW"";1//^S X=""WHOLE BLOOD"";S LR(65.54,1)=X;S:X=""N"" Y=2;1.1//^S X=""HOMOLOGOUS"";S LR(65.54,1.1)=X;S:X=""A"" LRA=LRP;S LRT=X;S:""AD""'[X Y=0;W !!;1.2//^S X=LRA;S Y=0;2"
- +1 DO ^DIE
- IF $DATA(Y)
- if $PIECE(^LRE(LRQ,5,LRI,0),U,4)]""
- GOTO DNR
- WRITE $CHAR(7),!!,"Delete all data from this donation "
- SET %=2
- DO YN^LRU
- if %'=1
- GOTO A
- SET DA=LRI
- SET DIK="^LRE(LRQ,5,"
- DO ^DIK
- KILL DIK
- GOTO DNR
- +2 IF LR(65.54,1.1)="A"
- IF '$PIECE(^LRE(LRQ,5,LRI,0),U,12)
- WRITE $CHAR(7),!!,"Autologous donation and RESTRICTED FOR: field not entered.",!,"Delete all data from this donation "
- SET %=2
- DO YN^LRU
- if %'=1
- GOTO A
- SET DA=LRI
- SET DIK="^LRE(LRQ,5,"
- DO ^DIK
- KILL DIK
- GOTO DNR
- +3 IF LR(65.54,1)="N"
- DO EN^LRBLY
- if LRCAPA
- DO N^LRBLWD
- GOTO DNR
- +4 SET LR(65.54)=LR(65.54,1.1)_LR(65.54,1)
- SET X1=9999999-LRI
- SET X2=-55
- DO C^%DTC
- SET Z(1)=9999999-X
- +5 FOR X=LRI:0
- SET X=$ORDER(^LRE(LRQ,5,X))
- if 'X!(X>Z(1))
- QUIT
- SET Y=$PIECE(^(X,0),"^",2)
- IF LR(65.54,1)="W"
- IF LR(65.54,1.1)="H"
- IF Y="W"
- WRITE !!,"LAST WHOLE BLOOD DONATION "
- SET LRC=1
- SET (Y,Z)=+^(0)
- DO D^LRU
- WRITE Y
- QUIT
- +6 IF $DATA(LRC)
- SET X1=LRAD
- SET X2=Z
- DO ^%DTC
- IF X<56
- WRITE $CHAR(7),!!,"SORRY NOT 8 WEEKS SINCE LAST DONATION OF WHOLE BLOOD"
- SET X1=Z
- SET X2=56
- DO C^%DTC
- SET Y=X
- DO D^LRU
- WRITE !,"COME BACK ON OR AFTER ",Y
- DO RES
- if LRCAPA
- DO N^LRBLWD
- GOTO DNR
- +7 IF LRCAPA
- DO @(LR(65.54)_"^LRBLWD")
- +8 DO EN^LRBLY
- WRITE !,"Enter donor in list for printing registration form "
- SET %=2
- DO YN^LRU
- if %'=1
- GOTO MORE
- +9 SET ^LRO(69.2,LRAA,5,LRQ,0)=LRQ_"^65.5^"_LRP
- SET ^LRO(69.2,LRAA,5,"C",LRP,LRQ)=""
- GOTO DNR
- MORE WRITE !!,"Continue to enter collection information "
- SET %=1
- DO YN^LRU
- if %'=1
- GOTO DNR
- +1 KILL DA,DR,DIE,DIC,DR,DQ
- SET (DIC,DIE)="^LRE("
- SET DA=LRQ
- SET DR="[LRBLDCPN]"
- DO ^DIE
- GOTO DNR
- ADD SET DR=$SELECT(LRH(2):"[LRBLDNEWM]",1:"[LRBLDNEW]")
- DO ^DIE
- QUIT
- RES SET X=^LRE(LRQ,5,LRI,0)
- SET ^(0)=$PIECE(X,"^")_"^"_"N"_"^"_$PIECE(X,"^",3,99)
- QUIT
- END DO V^LRU
- QUIT