- 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 Mar 13, 2025@21:14:50 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
