- LRBLDUC ;AVAMC/REG/CYM - DONOR ABO/RH RECHECK ;7/5/96 22:39 ;
- ;;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 V^LRU S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
- W !!?30,"Donor ABO/Rh Recheck",! I LRCAPA S X="DONOR ABO/RH RECHECK" D X^LRUWK G:'$D(X) END S Y="UC" D S^LRBLWD
- S LRB="",LRC=1 W !!,"Enter TEST COMMENT(s) " S %=2 D YN^LRU K:%=1 LRC
- DNR W ! K DA,LR,LRR S DIC="^LRE(",DIC(0)="AFQM",D="C^B",DIC("B")=LRB,DIC("A")="Select DONOR ID: " D MIX^DIC1 K DIC G:X=""!(X[U) END
- I Y<1 W $C(7),!!,"Complete DONOR ID must be entered (ex. If ID=H12345 then H123 unacceptable)." G DNR
- I X["," D ASK G:Y<1 DNR D CKRL,REST G DNR
- S LRQ=+Y,LRI=$O(^LRE("C",X,LRQ,0)) I 'LRI W $C(7)," ",X," does not exist. Try again" G DNR
- L +^LRE(LRQ,5,LRI,0):5 I '$T W !!,$C(7),"Sorry, someone else is editing this record" G DNR
- S LRQ(1)=$P(^LRE(LRQ,5,LRI,0),"^",4) D CKRL,REST L -^LRE(LRQ,5,LRI,0) G DNR
- ;
- REST S X(1)=$E(X,3,$L(X)),X(2)=X(1)+1,X(3)=$L(X(1))-$L(X(2)) I X(3) S X(2)=$E("00000",1,X(3))_X(2)
- S LRB=$E(X,1,2)_X(2),LRB=$S($D(^LRE("C",LRB)):LRB,1:"")
- S X=^LRE(LRQ,0),W(5)=$P(X,U,5),W(6)=$P(X,U,6)
- S Y=+^LRE(LRQ,5,LRI,0) D D^LRU W !!,"UNIT#:",LRQ(1)," Donation date:",Y I LRQ(1)="" W $C(7),!?35,"Must have UNIT # to proceed." Q
- W ! S DR="[LRBLDUC]",DIE="^LRE(",DA=LRQ D ^DIE K DIE,DR
- I $D(LRR) F A=0:0 S A=$O(LRA(A)) Q:'A I $D(^LRE(LRQ,5,LRI,A)),$P(^(A),"^") S LR=1
- I $D(LRR),'$D(^XUSEC("LRBLSUPER",DUZ)) W !,"One or more components were released. You may not edit existing test results."
- S Y="UC" D:LRCAPA SET^LRBLWD Q
- S ;from LRBLDUC input template only supervisor can edit data after release of components
- I $D(LRR),$P(LRM,U,4)]"",'$D(^XUSEC("LRBLSUPER",DUZ)) S Y=Z
- I $P(LRM,U)="" W $C(7),!,"ABO/Rh testing not completed." S Y=0
- Q
- ASK S LRQ=+Y,DIC="^LRE(LRQ,5,",DIC(0)="FAEQM",DIC("A")="Select DONATION DATE: " D ^DIC K DIC Q:Y<1
- S LRI=+Y,LRQ(1)=$P(^LRE(LRQ,5,LRI,0),U,4) Q
- ;
- CKRL F A=0:0 S A=$O(^LRE(LRQ,5,LRI,66,A)) Q:'A I $P(^(A,0),"^",8)=0 S LRR=1 Q
- Q
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDUC 2110 printed Feb 18, 2025@23:36:50 Page 2
- LRBLDUC ;AVAMC/REG/CYM - DONOR ABO/RH RECHECK ;7/5/96 22:39 ;
- +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 V^LRU
- SET X="BLOOD BANK"
- DO ^LRUTL
- if Y=-1
- GOTO END
- +4 WRITE !!?30,"Donor ABO/Rh Recheck",!
- IF LRCAPA
- SET X="DONOR ABO/RH RECHECK"
- DO X^LRUWK
- if '$DATA(X)
- GOTO END
- SET Y="UC"
- DO S^LRBLWD
- +5 SET LRB=""
- SET LRC=1
- WRITE !!,"Enter TEST COMMENT(s) "
- SET %=2
- DO YN^LRU
- if %=1
- KILL LRC
- DNR WRITE !
- KILL DA,LR,LRR
- SET DIC="^LRE("
- SET DIC(0)="AFQM"
- SET D="C^B"
- SET DIC("B")=LRB
- SET DIC("A")="Select DONOR ID: "
- DO MIX^DIC1
- KILL DIC
- if X=""!(X[U)
- GOTO END
- +1 IF Y<1
- WRITE $CHAR(7),!!,"Complete DONOR ID must be entered (ex. If ID=H12345 then H123 unacceptable)."
- GOTO DNR
- +2 IF X[","
- DO ASK
- if Y<1
- GOTO DNR
- DO CKRL
- DO REST
- GOTO DNR
- +3 SET LRQ=+Y
- SET LRI=$ORDER(^LRE("C",X,LRQ,0))
- IF 'LRI
- WRITE $CHAR(7)," ",X," does not exist. Try again"
- GOTO DNR
- +4 LOCK +^LRE(LRQ,5,LRI,0):5
- IF '$TEST
- WRITE !!,$CHAR(7),"Sorry, someone else is editing this record"
- GOTO DNR
- +5 SET LRQ(1)=$PIECE(^LRE(LRQ,5,LRI,0),"^",4)
- DO CKRL
- DO REST
- LOCK -^LRE(LRQ,5,LRI,0)
- GOTO DNR
- +6 ;
- REST SET X(1)=$EXTRACT(X,3,$LENGTH(X))
- SET X(2)=X(1)+1
- SET X(3)=$LENGTH(X(1))-$LENGTH(X(2))
- IF X(3)
- SET X(2)=$EXTRACT("00000",1,X(3))_X(2)
- +1 SET LRB=$EXTRACT(X,1,2)_X(2)
- SET LRB=$SELECT($DATA(^LRE("C",LRB)):LRB,1:"")
- +2 SET X=^LRE(LRQ,0)
- SET W(5)=$PIECE(X,U,5)
- SET W(6)=$PIECE(X,U,6)
- +3 SET Y=+^LRE(LRQ,5,LRI,0)
- DO D^LRU
- WRITE !!,"UNIT#:",LRQ(1)," Donation date:",Y
- IF LRQ(1)=""
- WRITE $CHAR(7),!?35,"Must have UNIT # to proceed."
- QUIT
- +4 WRITE !
- SET DR="[LRBLDUC]"
- SET DIE="^LRE("
- SET DA=LRQ
- DO ^DIE
- KILL DIE,DR
- +5 IF $DATA(LRR)
- FOR A=0:0
- SET A=$ORDER(LRA(A))
- if 'A
- QUIT
- IF $DATA(^LRE(LRQ,5,LRI,A))
- IF $PIECE(^(A),"^")
- SET LR=1
- +6 IF $DATA(LRR)
- IF '$DATA(^XUSEC("LRBLSUPER",DUZ))
- WRITE !,"One or more components were released. You may not edit existing test results."
- +7 SET Y="UC"
- if LRCAPA
- DO SET^LRBLWD
- QUIT
- S ;from LRBLDUC input template only supervisor can edit data after release of components
- +1 IF $DATA(LRR)
- IF $PIECE(LRM,U,4)]""
- IF '$DATA(^XUSEC("LRBLSUPER",DUZ))
- SET Y=Z
- +2 IF $PIECE(LRM,U)=""
- WRITE $CHAR(7),!,"ABO/Rh testing not completed."
- SET Y=0
- +3 QUIT
- ASK SET LRQ=+Y
- SET DIC="^LRE(LRQ,5,"
- SET DIC(0)="FAEQM"
- SET DIC("A")="Select DONATION DATE: "
- DO ^DIC
- KILL DIC
- if Y<1
- QUIT
- +1 SET LRI=+Y
- SET LRQ(1)=$PIECE(^LRE(LRQ,5,LRI,0),U,4)
- QUIT
- +2 ;
- CKRL FOR A=0:0
- SET A=$ORDER(^LRE(LRQ,5,LRI,66,A))
- if 'A
- QUIT
- IF $PIECE(^(A,0),"^",8)=0
- SET LRR=1
- QUIT
- +1 QUIT
- END DO V^LRU
- QUIT