LRBLB ;AVAMC/REG/CRT - BLOOD BANK BAR CODE READER ; 12/5/00 11:16am
;;5.2;LAB SERVICE**247,267**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
X S X=$E(X,LR,$L(X)),A=$E(X),B=$E(X,$L(X)) Q
W W ?32,"(Bar code)" Q
STRIP(X) ; Strip off any ISBT-128 barcode identifier characters
S X=$TR(X,"=<>&%(","")
Q X
;
U ;from LRBLDRR, LRBLJLG
I $$ISBTUID(.X) Q
S X=$$STRIP(X)
D X I 'LR(3),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 X=A_$E(X,3,7)
D W W ?45,"UNIT ID: ",X Q
Q
A ;ABO/RH GROUPING
N XX ; used to preserve original value to redisplay if invalid
D ISBTBG(X,.LRABO,.LRRH)
I LRABO]"" D W,EN^DDIOL("ABO/Rh: "_LRABO_" "_LRRH,"","?47") Q
S XX=$$STRIP(.X)
D X I X?3N,$E(X,3)=0 S A=$T(@(+$E(X,1,2))),X=$P(A,";",3) I X="" K X W XX Q:'$D(X) D W W ?46,"ABO/Rh: ",X S LRABO=$P(X," "),LRRH=$P(X," ",2) Q
Q
P ;PRODUCT CODE
I $$ISBTPC(.X) Q
S X=$$STRIP(X)
D X
I X?7N&(A=0!(A=3))&(B=3) D
.S X=$E(X,2,6),Y=0
.D W,C
E W X
Q
C N XX S XX=X K X S X=XX ; need to remove leftover X subnodes!!
F A=1:1 S Y=$O(^LAB(66,"D",X,Y)) Q:'Y S X(A)=Y_"^"_^LAB(66,Y,0)
I A=2 S W(4)=+X(1),P=$P(X(1),U,2),W(9)=$P(X(1),U,20),LRV=$P(X(1),U,11),LRJ=$P(X(1),U,26),X=P W !?24,P Q
W ! S Y=0 F A=0:1 S Y=$O(X(Y)) Q:'Y W !?2,Y,")",?5,$P(X(Y),U,2)
I A=0 D K X Q
.W !!?28,"Product Code '",X,"' not found."
.W !?28,"Please add to the Blood Product File"
H W !,"CHOOSE 1-",A,": " R X:DTIME I X=""!(X[U) K X Q
I X<1!(X>A) W $C(7) G H
S W(4)=+X(X),P=$P(X(X),U,2),W(9)=$P(X(X),U,20),LRV=$P(X(X),U,11),LRJ=$P(X(X),U,26),X=P W ?25,P Q
R ;FDA REG #
D X I X?9N&(B=1)&(A=0!(A=1)) S X=$E(X,2,8) D W W !?2,"Registration number: ",X Q
Q
D ;DATE CODE
I $$ISBTED(.X) Q
S X=$$STRIP(X)
D X I X'?6N&(X'?8N) W X Q
S %DT="" D ^%DT S W(6)=Y I Y<1 K X Q
D D^LRU D W W ?44,"Exp date: ",Y Q
BAR ;TEST BAR CODE READER
S LR="" W !!?28,"To use BAR CODE READER",!?15,"Pass reader wand over a GROUP-TYPE (ABO/Rh) label",! S X=$$READ("=>",25) Q:X=""!(X["^") W " (bar code)"
D ISBTBG(X,.LRABO,.LRRH) I LRABO]"" D Q
.S LR=1,LR(2)=""
.W " ",LRABO," ",LRRH
S X=$$STRIP(X)
F A=1:1 S Y=$P($T(G+A),";",4) Q:Y="" S X(1)=$F(X,Y) I X(1),$L(X)<X(1) S LR=$L(X)-3,LR(2)=$E(X,1,LR),LR=LR+1 Q
I LR="" W $C(7),!!?28,"Not a GROUP-TYPE label",!?15,"Press <RETURN> key if BAR CODE READER is not used",! G BAR
W " ",$P($T(G+A),";",3) K X Q
;
T ;from LRBLDRR1, LRBLJLG
F A=1:1 S Y=$P($T(G+A),";",3) Q:Y="" S:X=$E(Y,1,$L(X)) X(A)=Y
I $D(X)'=11 K X D S Q
K Y S Y=0 F A=1:1 S Y=$O(X(Y)) Q:'Y S Y(A)=X(Y) K X(Y)
I A=2 S LRABO=$P(Y(1)," ",1),LRRH=$P(Y(1)," ",2) W $E(Y(1),$L(X)+1,$L(Y(1))) Q
W ! S Y=0 F A=0:1 S Y=$O(Y(Y)) Q:'Y W !?2,Y,")",?5,Y(Y)
AG W !,"CHOOSE 1-",A,": " R X:DTIME I X=""!(X["^") K X Q
I X<1!(X>A) W $C(7) G AG
W " ",Y(X) S LRABO=$P(Y(X)," ",1),LRRH=$P(Y(X)," ",2) Q
S W !!,"Select from (NA=not applicable): " F A=1:1 W !?15,$P($T(G+A),";",3) Q:$T(G+A)=""
Q
;
ISBTUID(LRBLIN) ; Check for and display valid ISBT-128 Unit Id
; Valid codes are prefixed by "="
;
; INPUT : LRBLIN = input from Unit Id barcode label.
; OUTPUT : Boolean
;
Q:$E(LRBLIN,1,2)'?1"="1(1A,1N) 0
S LRBLIN=$E(LRBLIN,2,14)
S LRBLIN=$$UP^XLFSTR(LRBLIN) ; make uppercase
D W
D EN^DDIOL("UNIT ID: "_LRBLIN,"","?46")
Q 1
;
ISBTBG(IN,LRBLABO,LRBLRH) ; Check for ISBT-128 valid Blood Group
; and return ABO & Rh values
; Valid codes are prefixed by "=%"
;
; INPUT : IN = input from Blood Group barcode label.
; OUTPUT : LRBLABO (passed by reference) = ABO value
; LRBLRH (passed by reference) = Rh value
;
S (LRBLABO,LRBLRH)=""
Q:$L(IN)'>3
Q:$E(IN,1,2)'="=%"
S IN=$E(IN,3,4)
S LRABO=$S(90<IN&(IN<99):"O NEG",46<IN&(IN<55):"O POS",1<IN&(IN<10):"A NEG",57<IN&(IN<66):"A POS",12<IN&(IN<21):"B NEG",68<IN&(IN<77):"B POS",23<IN&(IN<32):"AB NEG",79<IN&(IN<88):"AB POS",1:"")
Q:LRABO=""
S LRBLRH=$P(LRBLABO," ",2)
S LRBLABO=$P(LRBLABO," ")
Q
;
ISBTPC(LRBLIN) ; Check for and display valid ISBT-128 Product Code
; Valid codes prefixed by "=<"
;
; INPUT : LRBLIN = input from Product Code barcode label
; OUTPUT : Boolean
;
Q:$E(LRBLIN,1,2)'="=<" 0
S LRBLIN=$E(LRBLIN,3,$L(LRBLIN))
S LRBLIN=$$UP^XLFSTR(LRBLIN)
S Y=0
S X=LRBLIN D W,C
;I A=0 D
;.D EN^DDIOL("Product Code not found.",,"!!?28")
;.D EN^DDIOL("Please add to the Blood Product File",,"!?28")
Q 1
;
ISBTED(LRBLIN) ; Check for and display valid ISBT-128 Expiration Date
; Valid codes are prefixed by "&>"
;
; INPUT : LRBLIN = input from Expiration Date barcode label
; OUTPUT : Boolean
;
N X,Y
;
Q:$E(LRBLIN,1,2)'="&>" 0
S LRBLIN=$E(LRBLIN,3,$L(LRBLIN))
S X=$$JULIAN(LRBLIN)
Q:'X 0
S (W(6),Y)=$P(X,".")_"."_$S($E(LRBLIN,7,10)]"":$E(LRBLIN,7,10),1:"2359")
D D^LRU,W
S LRBLIN=$E(Y,1,12)_"@"_$E(Y,14,18) ; Set LRBLIN to valid input
D EN^DDIOL("Exp date: "_Y,"","?45")
Q 1
;
JULIAN(LRBLJD) ;; Julian Date Conversion
;
; INPUT : LRBLJD = Julian Date (format = CYYDDD)
; If C=9 then 19YY, else 2CYY
; DDD=number of days in year (eg 128 = MAY 8)
; OUTPUT : FileMan date or 0 if invalid
;
N X,%H,%T,%Y,%
;
; Put year only into FileMan format
S X=$S($E(LRBLJD)="9":1900,1:2000+($E(LRBLJD)*100))
S X=X+$E(LRBLJD,2,3)
S X=X-1700
S X=X_"0101"
; Get $H value of Jan 1st
D H^%DTC
Q:'%H 0
; Add days to $H value
S %H=%H+$E(LRBLJD,4,6)-1
; Put date back into FileMan format
D YX^%DTC
Q +X
;
READ(PROMPT,POS) ; This extrinsic function will be used to present a prompt that can receive input from a
; scanner or manual data entry. This function returns the entire value of the input.
;
N X
S:'$G(POS) POS=0
W ?POS,PROMPT
R X:DTIME
W $C(13),$J("",79),$C(13),$J("",POS),PROMPT
Q X
G ;;
51 ;;O POS;510
62 ;;A POS;620
73 ;;B POS;730
84 ;;AB POS;840
95 ;;O NEG;950
6 ;;A NEG;060
17 ;;B NEG;170
28 ;;AB NEG;280
55 ;;O;550
66 ;;A;660
77 ;;B;770
88 ;;AB;880
;;NA NA;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLB 6069 printed Sep 23, 2025@19:45:55 Page 2
LRBLB ;AVAMC/REG/CRT - BLOOD BANK BAR CODE READER ; 12/5/00 11:16am
+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
X SET X=$EXTRACT(X,LR,$LENGTH(X))
SET A=$EXTRACT(X)
SET B=$EXTRACT(X,$LENGTH(X))
QUIT
W WRITE ?32,"(Bar code)"
QUIT
STRIP(X) ; Strip off any ISBT-128 barcode identifier characters
+1 SET X=$TRANSLATE(X,"=<>&%(","")
+2 QUIT X
+3 ;
U ;from LRBLDRR, LRBLJLG
+1 IF $$ISBTUID(.X)
QUIT
+2 SET X=$$STRIP(X)
+3 DO X
IF 'LR(3)
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 X=A_$EXTRACT(X,3,7)
+4 DO W
WRITE ?45,"UNIT ID: ",X
QUIT
+5 QUIT
A ;ABO/RH GROUPING
+1 ; used to preserve original value to redisplay if invalid
NEW XX
+2 DO ISBTBG(X,.LRABO,.LRRH)
+3 IF LRABO]""
DO W
DO EN^DDIOL("ABO/Rh: "_LRABO_" "_LRRH,"","?47")
QUIT
+4 SET XX=$$STRIP(.X)
+5 DO X
IF X?3N
IF $EXTRACT(X,3)=0
SET A=$TEXT(@(+$EXTRACT(X,1,2)))
SET X=$PIECE(A,";",3)
IF X=""
KILL X
WRITE XX
if '$DATA(X)
QUIT
DO W
WRITE ?46,"ABO/Rh: ",X
SET LRABO=$PIECE(X," ")
SET LRRH=$PIECE(X," ",2)
QUIT
+6 QUIT
P ;PRODUCT CODE
+1 IF $$ISBTPC(.X)
QUIT
+2 SET X=$$STRIP(X)
+3 DO X
+4 IF X?7N&(A=0!(A=3))&(B=3)
Begin DoDot:1
+5 SET X=$EXTRACT(X,2,6)
SET Y=0
+6 DO W
DO C
End DoDot:1
+7 IF '$TEST
WRITE X
+8 QUIT
C ; need to remove leftover X subnodes!!
NEW XX
SET XX=X
KILL X
SET X=XX
+1 FOR A=1:1
SET Y=$ORDER(^LAB(66,"D",X,Y))
if 'Y
QUIT
SET X(A)=Y_"^"_^LAB(66,Y,0)
+2 IF A=2
SET W(4)=+X(1)
SET P=$PIECE(X(1),U,2)
SET W(9)=$PIECE(X(1),U,20)
SET LRV=$PIECE(X(1),U,11)
SET LRJ=$PIECE(X(1),U,26)
SET X=P
WRITE !?24,P
QUIT
+3 WRITE !
SET Y=0
FOR A=0:1
SET Y=$ORDER(X(Y))
if 'Y
QUIT
WRITE !?2,Y,")",?5,$PIECE(X(Y),U,2)
+4 IF A=0
Begin DoDot:1
+5 WRITE !!?28,"Product Code '",X,"' not found."
+6 WRITE !?28,"Please add to the Blood Product File"
End DoDot:1
KILL X
QUIT
H WRITE !,"CHOOSE 1-",A,": "
READ X:DTIME
IF X=""!(X[U)
KILL X
QUIT
+1 IF X<1!(X>A)
WRITE $CHAR(7)
GOTO H
+2 SET W(4)=+X(X)
SET P=$PIECE(X(X),U,2)
SET W(9)=$PIECE(X(X),U,20)
SET LRV=$PIECE(X(X),U,11)
SET LRJ=$PIECE(X(X),U,26)
SET X=P
WRITE ?25,P
QUIT
R ;FDA REG #
+1 DO X
IF X?9N&(B=1)&(A=0!(A=1))
SET X=$EXTRACT(X,2,8)
DO W
WRITE !?2,"Registration number: ",X
QUIT
+2 QUIT
D ;DATE CODE
+1 IF $$ISBTED(.X)
QUIT
+2 SET X=$$STRIP(X)
+3 DO X
IF X'?6N&(X'?8N)
WRITE X
QUIT
+4 SET %DT=""
DO ^%DT
SET W(6)=Y
IF Y<1
KILL X
QUIT
+5 DO D^LRU
DO W
WRITE ?44,"Exp date: ",Y
QUIT
BAR ;TEST BAR CODE READER
+1 SET LR=""
WRITE !!?28,"To use BAR CODE READER",!?15,"Pass reader wand over a GROUP-TYPE (ABO/Rh) label",!
SET X=$$READ("=>",25)
if X=""!(X["^")
QUIT
WRITE " (bar code)"
+2 DO ISBTBG(X,.LRABO,.LRRH)
IF LRABO]""
Begin DoDot:1
+3 SET LR=1
SET LR(2)=""
+4 WRITE " ",LRABO," ",LRRH
End DoDot:1
QUIT
+5 SET X=$$STRIP(X)
+6 FOR A=1:1
SET Y=$PIECE($TEXT(G+A),";",4)
if Y=""
QUIT
SET X(1)=$FIND(X,Y)
IF X(1)
IF $LENGTH(X)<X(1)
SET LR=$LENGTH(X)-3
SET LR(2)=$EXTRACT(X,1,LR)
SET LR=LR+1
QUIT
+7 IF LR=""
WRITE $CHAR(7),!!?28,"Not a GROUP-TYPE label",!?15,"Press <RETURN> key if BAR CODE READER is not used",!
GOTO BAR
+8 WRITE " ",$PIECE($TEXT(G+A),";",3)
KILL X
QUIT
+9 ;
T ;from LRBLDRR1, LRBLJLG
+1 FOR A=1:1
SET Y=$PIECE($TEXT(G+A),";",3)
if Y=""
QUIT
if X=$EXTRACT(Y,1,$LENGTH(X))
SET X(A)=Y
+2 IF $DATA(X)'=11
KILL X
DO S
QUIT
+3 KILL Y
SET Y=0
FOR A=1:1
SET Y=$ORDER(X(Y))
if 'Y
QUIT
SET Y(A)=X(Y)
KILL X(Y)
+4 IF A=2
SET LRABO=$PIECE(Y(1)," ",1)
SET LRRH=$PIECE(Y(1)," ",2)
WRITE $EXTRACT(Y(1),$LENGTH(X)+1,$LENGTH(Y(1)))
QUIT
+5 WRITE !
SET Y=0
FOR A=0:1
SET Y=$ORDER(Y(Y))
if 'Y
QUIT
WRITE !?2,Y,")",?5,Y(Y)
AG WRITE !,"CHOOSE 1-",A,": "
READ X:DTIME
IF X=""!(X["^")
KILL X
QUIT
+1 IF X<1!(X>A)
WRITE $CHAR(7)
GOTO AG
+2 WRITE " ",Y(X)
SET LRABO=$PIECE(Y(X)," ",1)
SET LRRH=$PIECE(Y(X)," ",2)
QUIT
S WRITE !!,"Select from (NA=not applicable): "
FOR A=1:1
WRITE !?15,$PIECE($TEXT(G+A),";",3)
if $TEXT(G+A)=""
QUIT
+1 QUIT
+2 ;
ISBTUID(LRBLIN) ; Check for and display valid ISBT-128 Unit Id
+1 ; Valid codes are prefixed by "="
+2 ;
+3 ; INPUT : LRBLIN = input from Unit Id barcode label.
+4 ; OUTPUT : Boolean
+5 ;
+6 if $EXTRACT(LRBLIN,1,2)'?1"="1(1A,1N)
QUIT 0
+7 SET LRBLIN=$EXTRACT(LRBLIN,2,14)
+8 ; make uppercase
SET LRBLIN=$$UP^XLFSTR(LRBLIN)
+9 DO W
+10 DO EN^DDIOL("UNIT ID: "_LRBLIN,"","?46")
+11 QUIT 1
+12 ;
ISBTBG(IN,LRBLABO,LRBLRH) ; Check for ISBT-128 valid Blood Group
+1 ; and return ABO & Rh values
+2 ; Valid codes are prefixed by "=%"
+3 ;
+4 ; INPUT : IN = input from Blood Group barcode label.
+5 ; OUTPUT : LRBLABO (passed by reference) = ABO value
+6 ; LRBLRH (passed by reference) = Rh value
+7 ;
+8 SET (LRBLABO,LRBLRH)=""
+9 if $LENGTH(IN)'>3
QUIT
+10 if $EXTRACT(IN,1,2)'="=%"
QUIT
+11 SET IN=$EXTRACT(IN,3,4)
+12 SET LRABO=$SELECT(90<IN&(IN<99):"O NEG",46<IN&(IN<55):"O POS",1<IN&(IN<10):"A NEG",57<IN&(IN<66):"A POS",12<IN&(IN<21):"B NEG",68<IN&(IN<77):"B POS",23<IN&(IN<32):"AB NEG",79<IN&(IN<88):"AB POS",1:"")
+13 if LRABO=""
QUIT
+14 SET LRBLRH=$PIECE(LRBLABO," ",2)
+15 SET LRBLABO=$PIECE(LRBLABO," ")
+16 QUIT
+17 ;
ISBTPC(LRBLIN) ; Check for and display valid ISBT-128 Product Code
+1 ; Valid codes prefixed by "=<"
+2 ;
+3 ; INPUT : LRBLIN = input from Product Code barcode label
+4 ; OUTPUT : Boolean
+5 ;
+6 if $EXTRACT(LRBLIN,1,2)'="=<"
QUIT 0
+7 SET LRBLIN=$EXTRACT(LRBLIN,3,$LENGTH(LRBLIN))
+8 SET LRBLIN=$$UP^XLFSTR(LRBLIN)
+9 SET Y=0
+10 SET X=LRBLIN
DO W
DO C
+11 ;I A=0 D
+12 ;.D EN^DDIOL("Product Code not found.",,"!!?28")
+13 ;.D EN^DDIOL("Please add to the Blood Product File",,"!?28")
+14 QUIT 1
+15 ;
ISBTED(LRBLIN) ; Check for and display valid ISBT-128 Expiration Date
+1 ; Valid codes are prefixed by "&>"
+2 ;
+3 ; INPUT : LRBLIN = input from Expiration Date barcode label
+4 ; OUTPUT : Boolean
+5 ;
+6 NEW X,Y
+7 ;
+8 if $EXTRACT(LRBLIN,1,2)'="&>"
QUIT 0
+9 SET LRBLIN=$EXTRACT(LRBLIN,3,$LENGTH(LRBLIN))
+10 SET X=$$JULIAN(LRBLIN)
+11 if 'X
QUIT 0
+12 SET (W(6),Y)=$PIECE(X,".")_"."_$SELECT($EXTRACT(LRBLIN,7,10)]"":$EXTRACT(LRBLIN,7,10),1:"2359")
+13 DO D^LRU
DO W
+14 ; Set LRBLIN to valid input
SET LRBLIN=$EXTRACT(Y,1,12)_"@"_$EXTRACT(Y,14,18)
+15 DO EN^DDIOL("Exp date: "_Y,"","?45")
+16 QUIT 1
+17 ;
JULIAN(LRBLJD) ;; Julian Date Conversion
+1 ;
+2 ; INPUT : LRBLJD = Julian Date (format = CYYDDD)
+3 ; If C=9 then 19YY, else 2CYY
+4 ; DDD=number of days in year (eg 128 = MAY 8)
+5 ; OUTPUT : FileMan date or 0 if invalid
+6 ;
+7 NEW X,%H,%T,%Y,%
+8 ;
+9 ; Put year only into FileMan format
+10 SET X=$SELECT($EXTRACT(LRBLJD)="9":1900,1:2000+($EXTRACT(LRBLJD)*100))
+11 SET X=X+$EXTRACT(LRBLJD,2,3)
+12 SET X=X-1700
+13 SET X=X_"0101"
+14 ; Get $H value of Jan 1st
+15 DO H^%DTC
+16 if '%H
QUIT 0
+17 ; Add days to $H value
+18 SET %H=%H+$EXTRACT(LRBLJD,4,6)-1
+19 ; Put date back into FileMan format
+20 DO YX^%DTC
+21 QUIT +X
+22 ;
READ(PROMPT,POS) ; This extrinsic function will be used to present a prompt that can receive input from a
+1 ; scanner or manual data entry. This function returns the entire value of the input.
+2 ;
+3 NEW X
+4 if '$GET(POS)
SET POS=0
+5 WRITE ?POS,PROMPT
+6 READ X:DTIME
+7 WRITE $CHAR(13),$JUSTIFY("",79),$CHAR(13),$JUSTIFY("",POS),PROMPT
+8 QUIT X
G ;;
51 ;;O POS;510
62 ;;A POS;620
73 ;;B POS;730
84 ;;AB POS;840
95 ;;O NEG;950
6 ;;A NEG;060
17 ;;B NEG;170
28 ;;AB NEG;280
55 ;;O;550
66 ;;A;660
77 ;;B;770
88 ;;AB;880
+1 ;;NA NA;
