- 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 Feb 18, 2025@23:36:09 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;