LRBLDED ;AVAMC/REG/CYM - BLOOD DONOR EDIT ;5/1/97 12:10 ;
;;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
O Q D END S LRC="",LRD("U")=1
ASK S LRA=0 D G G:Y<1 END D REST G ASK
REST I 'LRA W $C(7),!?28,"DONOR PREVIOUSLY ENTERED.",!?3,"THIS OPTION IS FOR ENTERING OLD DATA ON DONORS NOT PREVIOUSLY ENTERED !" Q
S DR="[LRBLDOLD]" D ^DIE I $D(Y) W !,$C(7),"Respond to ALL prompts. No '^' allowed ! ENTRY DELETED" S DIK="^LRE(" D ^DIK K DIK Q
SH W @IOF S DR="0;1;2;4" D EN^DIQ W !,"EDIT above information: " S %=2 D YN^LRU Q:%<1 I %=1 K DR S DR="[LRBLDEMO]" D ^DIE G SH
S:'$D(^LRE(DA,5,0)) ^(0)="^65.54DA^^" S LRQ=DA
DD W ! K LRZ S DA(1)=LRQ,DIC="^LRE(LRQ,5,",DIC(0)="AEQLM",DLAYGO=65 D ^DIC K DIC,DLAYGO Q:Y<1
S DA=+Y,DIE="^LRE(LRQ,5,",DR=".011////^S X=DUZ;.14///^S X=""YES"";.01;.02//^S X=LRC;S:X LRC=$P(^LAB(65.4,X,0),U);.03;1//^S X=""WHOLE BLOOD"";S:X'=""N"" Y=1.1;2;S LRZ=1,Y=0;1.1//^S X=""HOMOLOGOUS"";3//^S X=""NONE"""
D ^DIE G:$D(Y)!($D(LRZ)) DD
ID R !,"DONOR UNIT ID: ",X:DTIME G:X=""!(X[U) DD S X(1)=DA D ^LRBLU I '$D(X) W $C(7),! W:$D(^DD(65.54,4,3)) ^(3) X:$D(^(4)) ^(4) G ID
S $P(^LRE(LRQ,5,DA,0),"^",4)=X,^LRE("C",X,LRQ,DA)="" G DD
;
D Q D END,G G:Y<1 END G:$D(LR("CK")) D S DR="[LRBLDEMO]" D ^DIE D FRE^LRU W @IOF S DR="0;1;2;4" D:$G(DA) EN^DIQ G D
E Q D END,D^LRBLU G:'$D(X) END D G G:Y<1 END G:$D(LR("CK")) E S DR="[LRBLDCP]" D ^DIE D FRE^LRU G E
B Q D END,G G:Y<1 END G:$D(LR("CK")) B S DR="[LRBLDEDIT]" D ^DIE D FRE^LRU G B
C Q D END,G G:Y<1 END G:$D(LR("CK")) C S DR="[LRBLDON]" D ^DIE D FRE^LRU K LRP G C
EN Q D G G:Y<1 END G:$D(LR("CK")) EN S DR=.085 D ^DIE D FRE^LRU G EN
R D ^LRBLDRR Q
G K LR("CK"),DA,DQ,DIC,DIE,DR S IOP="HOME" D ^%ZIS
I '$D(LRAA) S X="BLOOD BANK" D ^LRUTL K LRDPAF
S (DIC,DIE)="^LRE(",DIC(0)="AEQLMZ",DLAYGO=65,D="B^C^"_$S("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D") W ! D MIX^DIC1 K DIC,DLAYGO,DR Q:Y<1
S DA=+Y I $P(Y,U,3) S LRA=1,LRP=$P(Y,U,2) D ^LRBLD G:'$D(DA) G S Y=DA
D CK^LRU Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDED 2088 printed Dec 13, 2024@02:10:29 Page 2
LRBLDED ;AVAMC/REG/CYM - BLOOD DONOR EDIT ;5/1/97 12:10 ;
+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
O QUIT
DO END
SET LRC=""
SET LRD("U")=1
ASK SET LRA=0
DO G
if Y<1
GOTO END
DO REST
GOTO ASK
REST IF 'LRA
WRITE $CHAR(7),!?28,"DONOR PREVIOUSLY ENTERED.",!?3,"THIS OPTION IS FOR ENTERING OLD DATA ON DONORS NOT PREVIOUSLY ENTERED !"
QUIT
+1 SET DR="[LRBLDOLD]"
DO ^DIE
IF $DATA(Y)
WRITE !,$CHAR(7),"Respond to ALL prompts. No '^' allowed ! ENTRY DELETED"
SET DIK="^LRE("
DO ^DIK
KILL DIK
QUIT
SH WRITE @IOF
SET DR="0;1;2;4"
DO EN^DIQ
WRITE !,"EDIT above information: "
SET %=2
DO YN^LRU
if %<1
QUIT
IF %=1
KILL DR
SET DR="[LRBLDEMO]"
DO ^DIE
GOTO SH
+1 if '$DATA(^LRE(DA,5,0))
SET ^(0)="^65.54DA^^"
SET LRQ=DA
DD WRITE !
KILL LRZ
SET DA(1)=LRQ
SET DIC="^LRE(LRQ,5,"
SET DIC(0)="AEQLM"
SET DLAYGO=65
DO ^DIC
KILL DIC,DLAYGO
if Y<1
QUIT
+1 SET DA=+Y
SET DIE="^LRE(LRQ,5,"
SET DR=".011////^S X=DUZ;.14///^S X=""YES"";.01;.02//^S X=LRC;S:X LRC=$P(^LAB(65.4,X,0),U);.03;1//^S X=""WHOLE BLOOD"";S:X'=""N"" Y=1.1;2;S LRZ=1,Y=0;1.1//^S X=""HOMOLOGOUS"";3//^S X=""NONE"""
+2 DO ^DIE
if $DATA(Y)!($DATA(LRZ))
GOTO DD
ID READ !,"DONOR UNIT ID: ",X:DTIME
if X=""!(X[U)
GOTO DD
SET X(1)=DA
DO ^LRBLU
IF '$DATA(X)
WRITE $CHAR(7),!
if $DATA(^DD(65.54,4,3))
WRITE ^(3)
if $DATA(^(4))
XECUTE ^(4)
GOTO ID
+1 SET $PIECE(^LRE(LRQ,5,DA,0),"^",4)=X
SET ^LRE("C",X,LRQ,DA)=""
GOTO DD
+2 ;
D QUIT
DO END
DO G
if Y<1
GOTO END
if $DATA(LR("CK"))
GOTO D
SET DR="[LRBLDEMO]"
DO ^DIE
DO FRE^LRU
WRITE @IOF
SET DR="0;1;2;4"
if $GET(DA)
DO EN^DIQ
GOTO D
E QUIT
DO END
DO D^LRBLU
if '$DATA(X)
GOTO END
DO G
if Y<1
GOTO END
if $DATA(LR("CK"))
GOTO E
SET DR="[LRBLDCP]"
DO ^DIE
DO FRE^LRU
GOTO E
B QUIT
DO END
DO G
if Y<1
GOTO END
if $DATA(LR("CK"))
GOTO B
SET DR="[LRBLDEDIT]"
DO ^DIE
DO FRE^LRU
GOTO B
C QUIT
DO END
DO G
if Y<1
GOTO END
if $DATA(LR("CK"))
GOTO C
SET DR="[LRBLDON]"
DO ^DIE
DO FRE^LRU
KILL LRP
GOTO C
EN QUIT
DO G
if Y<1
GOTO END
if $DATA(LR("CK"))
GOTO EN
SET DR=.085
DO ^DIE
DO FRE^LRU
GOTO EN
R DO ^LRBLDRR
QUIT
G KILL LR("CK"),DA,DQ,DIC,DIE,DR
SET IOP="HOME"
DO ^%ZIS
+1 IF '$DATA(LRAA)
SET X="BLOOD BANK"
DO ^LRUTL
KILL LRDPAF
+2 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")
WRITE !
DO MIX^DIC1
KILL DIC,DLAYGO,DR
if Y<1
QUIT
+3 SET DA=+Y
IF $PIECE(Y,U,3)
SET LRA=1
SET LRP=$PIECE(Y,U,2)
DO ^LRBLD
if '$DATA(DA)
GOTO G
SET Y=DA
+4 DO CK^LRU
QUIT
+5 ;
END DO V^LRU
QUIT
