- LRBLBU ;AVAMC/REG/CYM/CRT - BB UNIT BAR CODE ;1/15/90 14:17 ; 11/30/00 3:34pm
- ;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- ; This routine interprets Codabar barcodes used to label
- ; the Unit ID of units of blood.
- ; Called from LRBLJCK, LRBLJD, LRBLJD1, LRBLJM, LRBLPED and LRBLPUS1.
- S LR("CODE")=0
- I $$ISBTUID^LRBLB(.X) Q
- S X=$$STRIP^LRBLB(X)
- D L
- I X?7N D
- . S A=+$E(X,1,2),B=A\20,B=$E("FGKL",B),A=A#20+1,A=$E("CEFGHJKLMNPQRSTVWXYZ",A),A=B_A
- . S (LR(3),X)=A_$E(X,3,7)
- . I '$D(^LRD(65,"C",X)),'$D(^LRD(65,"B",X)) S X=LR(4),LR("CODE")=1
- I $D(^LRD(65,"C",LR(4))),$D(^(LR(3))) G W
- I $D(^LRD(65,"B",LR(4))),$D(^(LR(3))) G W
- W ?32,"(Bar code)",?45,"UNIT ID: ",X Q
- ;
- L S X=$E(X,LR,$L(X)),A=$E(X,1),B=$E(X,$L(X)),LR(4)=X,LR(3)="?" Q
- ;
- W W !?15,"1. ",LR(3),!?15,"2. ",LR(4),!!,"Select 1 or 2: " R X:DTIME I X=""!(X["^") K X Q
- I X'=1&(X'=2) W $C(7),!!,"Enter number 1 or number 2",! G W
- S X=$S(X=1:LR(3),1:LR(4)) W ". ",X Q
- EN ;from LRBLDC
- I $$ISBTUID^LRBLB(.X) Q
- S X=$$STRIP^LRBLB(X)
- D L I X?7N S A=+$E(X,1,2),B=A\20,B=$E("FGKL",B),A=A#20+1,A=$E("CEFGHJKLMNPQRSTVWXYZ",A),A=B_A S (LR(3),X)=A_$E(X,3,7) I '$D(^LRE("C",X)) S X=LR(4)
- I $D(^LRE("C",LR(4))),$D(^(LR(3))) G W
- W " (Bar code)",?45,"UNIT ID: ",X,! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLBU 1341 printed Feb 18, 2025@23:36:10 Page 2
- LRBLBU ;AVAMC/REG/CYM/CRT - BB UNIT BAR CODE ;1/15/90 14:17 ; 11/30/00 3:34pm
- +1 ;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 ; This routine interprets Codabar barcodes used to label
- +4 ; the Unit ID of units of blood.
- +5 ; Called from LRBLJCK, LRBLJD, LRBLJD1, LRBLJM, LRBLPED and LRBLPUS1.
- +6 SET LR("CODE")=0
- +7 IF $$ISBTUID^LRBLB(.X)
- QUIT
- +8 SET X=$$STRIP^LRBLB(X)
- +9 DO L
- +10 IF X?7N
- Begin DoDot:1
- +11 SET A=+$EXTRACT(X,1,2)
- SET B=A\20
- SET B=$EXTRACT("FGKL",B)
- SET A=A#20+1
- SET A=$EXTRACT("CEFGHJKLMNPQRSTVWXYZ",A)
- SET A=B_A
- +12 SET (LR(3),X)=A_$EXTRACT(X,3,7)
- +13 IF '$DATA(^LRD(65,"C",X))
- IF '$DATA(^LRD(65,"B",X))
- SET X=LR(4)
- SET LR("CODE")=1
- End DoDot:1
- +14 IF $DATA(^LRD(65,"C",LR(4)))
- IF $DATA(^(LR(3)))
- GOTO W
- +15 IF $DATA(^LRD(65,"B",LR(4)))
- IF $DATA(^(LR(3)))
- GOTO W
- +16 WRITE ?32,"(Bar code)",?45,"UNIT ID: ",X
- QUIT
- +17 ;
- L SET X=$EXTRACT(X,LR,$LENGTH(X))
- SET A=$EXTRACT(X,1)
- SET B=$EXTRACT(X,$LENGTH(X))
- SET LR(4)=X
- SET LR(3)="?"
- QUIT
- +1 ;
- W WRITE !?15,"1. ",LR(3),!?15,"2. ",LR(4),!!,"Select 1 or 2: "
- READ X:DTIME
- IF X=""!(X["^")
- KILL X
- QUIT
- +1 IF X'=1&(X'=2)
- WRITE $CHAR(7),!!,"Enter number 1 or number 2",!
- GOTO W
- +2 SET X=$SELECT(X=1:LR(3),1:LR(4))
- WRITE ". ",X
- QUIT
- EN ;from LRBLDC
- +1 IF $$ISBTUID^LRBLB(.X)
- QUIT
- +2 SET X=$$STRIP^LRBLB(X)
- +3 DO L
- IF X?7N
- SET A=+$EXTRACT(X,1,2)
- SET B=A\20
- SET B=$EXTRACT("FGKL",B)
- SET A=A#20+1
- SET A=$EXTRACT("CEFGHJKLMNPQRSTVWXYZ",A)
- SET A=B_A
- SET (LR(3),X)=A_$EXTRACT(X,3,7)
- IF '$DATA(^LRE("C",X))
- SET X=LR(4)
- +4 IF $DATA(^LRE("C",LR(4)))
- IF $DATA(^(LR(3)))
- GOTO W
- +5 WRITE " (Bar code)",?45,"UNIT ID: ",X,!
- QUIT