- SRBL ;BIR/ADM - BLOOD PRODUCT VERIFICATION FOR VBECS ;09/01/05
- ;;3.0; Surgery ;**148,168**;24 Jun 93;Build 5
- ;
- ; Reference to AVUNIT^VBECA1B supported by DBIA #4629
- ;
- SCAN D BAR ; test bar code reader
- S SRQ=0,DFN=$P(^SRF(SRTN,0),"^") K ^TMP("SRBL",$J)
- D AVUNIT^VBECA1B("SRBL",DFN) ; get list of units available for the patient
- TST K DIR S DIR(0)="FA^1:50",(SRPROMPT,DIR("A"))="Enter Blood Product Identifier: "
- S DIR("?")="Enter or scan the Blood Product Unit Id" D ^DIR K DIR G END:$D(DTOUT)!$D(DUOUT)
- D CODA,MATCH I 'SRMATCH G SRNO
- I SRMATCH=1 S SRY=SRMATCH D SRYES Q
- D LIST I SRQ G END
- S SRY=Y D SRYES
- Q
- LIST W ! S Y=^TMP("SRBL",$J,0),Z=$P(Y,"^",7),SRSSN=$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,12)
- S SRNAME=$P(Y,"^",5)_","_$P(Y,"^",4)_" "_SRSSN
- S (SRI,SRZ)=0 F S SRZ=$O(SRBL(SRZ)) Q:'SRZ D
- .S Z=SRBL(SRZ),SRPROD=$P(Z,"^",4),X=$P(Z,"^",2) D ^%DT S SREXP=Y
- .W !!," ",SRZ_") Unit ID: ",SRUID,?45,SRPROD
- .W !,?4,"Patient: ",SRNAME,?45,"Expiration Date: " S Y=SREXP D DD^%DT W Y
- .S SRI=SRI+1
- W ! K DIR S DIR(0)="NO^1:"_SRI,DIR("A")="Select the blood product matching the unit label"
- D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRQ=1 Q
- S SRY=Y
- Q
- MATCH ; retrieve matching units from list of available units
- S (SRIDT,SRMATCH)=0 F S SRIDT=$O(^TMP("SRBL",$J,SRIDT)) Q:'SRIDT D
- .S X=^TMP("SRBL",$J,SRIDT)
- .I $P(X,"^",3)=SRUID!($P(X,"^",12)=SRUID) S SRMATCH=SRMATCH+1,SRBL(SRMATCH)=X W !,"Eye Readable ID: ",$P(X,"^",3),!
- ;RLM Match either scanned or eye-readable label
- Q
- CODA ; interpret Codabar barcodes used to label the Unit ID of blood component
- I $$ISBTUID(.X) S SRUID=X Q
- S SRUID=$$STRIP(X)
- W ?45,"UNIT ID: ",SRUID
- Q
- SRYES S X=$P(SRBL(SRY),"^",2) D ^%DT I Y<DT D D ASK Q
- .I SRMATCH=1 D LIST
- .W !!,?30,"**WARNING**",!!,"Today's date exceeds the blood product expiration date.",!
- W !!!,?25,"No Discrepancies Found",!!! K DIR S DIR(0)="FOA",DIR("A")="Press RETURN to continue" D ^DIR G END
- SRNO W !!,?30,"**WARNING**",!!
- W ?5,"There is no record that this unit has been assigned to this patient."
- W !!,?8," Please recheck the patient and blood product IDs.",!!
- ASK K DIR S DIR(0)="Y",DIR("A")="Do you want to scan another product (Y/N)",DIR("B")="YES" D ^DIR I Y D END G SCAN
- END K ^TMP("SRBL",$J),DIR,SR,SRBL,SREXP,SRI,SRIDT,SRMATCH,SRNAME,SRPROD,SRPROMPT,SRQ,SRSSN,SRUID,SRY,SRZ,X,Y,Z
- Q
- STRIP(X) ; strip off any ISBT-128 barcode identifier characters
- S X=$TR(X,"=<>&%(","")
- Q X
- BAR ; test bar code reader
- N A,SR,SRABO,SRRH,SRPROMPT,X,Y S SR=""
- K DIR S DIR(0)="FAO^1:20" S DIR("A",1)="",(SRPROMPT,DIR("A"))=" => "
- S DIR("A",2)=" To use BAR CODE READER"
- S DIR("A",3)=" Pass reader wand over a GROUP-TYPE (ABO/Rh) label"
- S DIR("?",2)=" To test scanner, scan a GROUP-TYPE (ABO/Rh) label. Otherwise, press"
- S DIR("?",1)="",DIR("?")=" the Enter key." D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT)!(X="")
- W $C(13),$J("",79),$C(13),SRPROMPT,"(Bar code)"
- D ISBTBG(X,.SRABO,.SRRH) I SRABO]"" D Q
- .S SR=1,SR(2)=""
- .W " ",SRABO," ",SRRH
- 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 SR=$L(X)-3,SR(2)=$E(X,1,SR),SR=SR+1 Q
- I SR="" W $C(7),!!?28,"Not a GROUP-TYPE label",!?15,"Press <ENTER> key if BAR CODE READER is not used",! G BAR
- W " ",$P($T(G+A),";",3)
- Q
- ISBTBG(SRIN,SRBLABO,SRBLRH) ; check for ISBT-128 valid blood group and return ABO & Rh values
- ; Valid codes are prefixed by "=%".
- ;
- ; INPUT : SRIN = input from Blood Group barcode label.
- ; OUTPUT : SRBLABO (passed by reference) = ABO value
- ; SRBLRH (passed by reference) = Rh value
- ;
- N Z S (SRBLABO,SRBLRH)=""
- Q:$L(SRIN)'>3
- Q:$E(SRIN,1,2)'="=%"
- S Z=$E(SRIN,3,4)
- S SRBLABO=$S(57<Z&(Z<66):"A POS",46<Z&(Z<55):"O POS",90<Z&(Z<99):"O NEG",1<Z&(Z<10):"A NEG",12<Z&(Z<21):"B NEG",68<Z&(Z<77):"B POS",23<Z&(Z<32):"AB NEG",79<Z&(Z<88):"AB POS",1:"")
- Q:SRBLABO=""
- S SRBLRH=$P(SRBLABO," ",2)
- S SRBLABO=$P(SRBLABO," ")
- Q
- ISBTUID(SRBLIN) ; Check for and display valid ISBT-128 Unit Id
- ; Valid codes are prefixed by "="
- ;
- ; INPUT : SRBLIN = input from Unit Id barcode label.
- ; OUTPUT : Boolean
- ;
- Q:$E(SRBLIN,1,2)'?1"="1(1A,1N) 0
- S SRBLIN=$E(SRBLIN,2,14)
- S SRBLIN=$$UP^XLFSTR(SRBLIN) ; make uppercase
- W $C(13),$J("",79),$C(13),SRPROMPT,?32,"(Bar code)"
- D EN^DDIOL("UNIT ID: "_SRBLIN,"","?46")
- Q 1
- 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[HSRBL 4616 printed Feb 19, 2025@00:05:32 Page 2
- SRBL ;BIR/ADM - BLOOD PRODUCT VERIFICATION FOR VBECS ;09/01/05
- +1 ;;3.0; Surgery ;**148,168**;24 Jun 93;Build 5
- +2 ;
- +3 ; Reference to AVUNIT^VBECA1B supported by DBIA #4629
- +4 ;
- SCAN ; test bar code reader
- DO BAR
- +1 SET SRQ=0
- SET DFN=$PIECE(^SRF(SRTN,0),"^")
- KILL ^TMP("SRBL",$JOB)
- +2 ; get list of units available for the patient
- DO AVUNIT^VBECA1B("SRBL",DFN)
- TST KILL DIR
- SET DIR(0)="FA^1:50"
- SET (SRPROMPT,DIR("A"))="Enter Blood Product Identifier: "
- +1 SET DIR("?")="Enter or scan the Blood Product Unit Id"
- DO ^DIR
- KILL DIR
- if $DATA(DTOUT)!$DATA(DUOUT)
- GOTO END
- +2 DO CODA
- DO MATCH
- IF 'SRMATCH
- GOTO SRNO
- +3 IF SRMATCH=1
- SET SRY=SRMATCH
- DO SRYES
- QUIT
- +4 DO LIST
- IF SRQ
- GOTO END
- +5 SET SRY=Y
- DO SRYES
- +6 QUIT
- LIST WRITE !
- SET Y=^TMP("SRBL",$JOB,0)
- SET Z=$PIECE(Y,"^",7)
- SET SRSSN=$EXTRACT(Z,1,3)_"-"_$EXTRACT(Z,4,5)_"-"_$EXTRACT(Z,6,12)
- +1 SET SRNAME=$PIECE(Y,"^",5)_","_$PIECE(Y,"^",4)_" "_SRSSN
- +2 SET (SRI,SRZ)=0
- FOR
- SET SRZ=$ORDER(SRBL(SRZ))
- if 'SRZ
- QUIT
- Begin DoDot:1
- +3 SET Z=SRBL(SRZ)
- SET SRPROD=$PIECE(Z,"^",4)
- SET X=$PIECE(Z,"^",2)
- DO ^%DT
- SET SREXP=Y
- +4 WRITE !!," ",SRZ_") Unit ID: ",SRUID,?45,SRPROD
- +5 WRITE !,?4,"Patient: ",SRNAME,?45,"Expiration Date: "
- SET Y=SREXP
- DO DD^%DT
- WRITE Y
- +6 SET SRI=SRI+1
- End DoDot:1
- +7 WRITE !
- KILL DIR
- SET DIR(0)="NO^1:"_SRI
- SET DIR("A")="Select the blood product matching the unit label"
- +8 DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
- SET SRQ=1
- QUIT
- +9 SET SRY=Y
- +10 QUIT
- MATCH ; retrieve matching units from list of available units
- +1 SET (SRIDT,SRMATCH)=0
- FOR
- SET SRIDT=$ORDER(^TMP("SRBL",$JOB,SRIDT))
- if 'SRIDT
- QUIT
- Begin DoDot:1
- +2 SET X=^TMP("SRBL",$JOB,SRIDT)
- +3 IF $PIECE(X,"^",3)=SRUID!($PIECE(X,"^",12)=SRUID)
- SET SRMATCH=SRMATCH+1
- SET SRBL(SRMATCH)=X
- WRITE !,"Eye Readable ID: ",$PIECE(X,"^",3),!
- End DoDot:1
- +4 ;RLM Match either scanned or eye-readable label
- +5 QUIT
- CODA ; interpret Codabar barcodes used to label the Unit ID of blood component
- +1 IF $$ISBTUID(.X)
- SET SRUID=X
- QUIT
- +2 SET SRUID=$$STRIP(X)
- +3 WRITE ?45,"UNIT ID: ",SRUID
- +4 QUIT
- SRYES SET X=$PIECE(SRBL(SRY),"^",2)
- DO ^%DT
- IF Y<DT
- Begin DoDot:1
- +1 IF SRMATCH=1
- DO LIST
- +2 WRITE !!,?30,"**WARNING**",!!,"Today's date exceeds the blood product expiration date.",!
- End DoDot:1
- DO ASK
- QUIT
- +3 WRITE !!!,?25,"No Discrepancies Found",!!!
- KILL DIR
- SET DIR(0)="FOA"
- SET DIR("A")="Press RETURN to continue"
- DO ^DIR
- GOTO END
- SRNO WRITE !!,?30,"**WARNING**",!!
- +1 WRITE ?5,"There is no record that this unit has been assigned to this patient."
- +2 WRITE !!,?8," Please recheck the patient and blood product IDs.",!!
- ASK KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you want to scan another product (Y/N)"
- SET DIR("B")="YES"
- DO ^DIR
- IF Y
- DO END
- GOTO SCAN
- END KILL ^TMP("SRBL",$JOB),DIR,SR,SRBL,SREXP,SRI,SRIDT,SRMATCH,SRNAME,SRPROD,SRPROMPT,SRQ,SRSSN,SRUID,SRY,SRZ,X,Y,Z
- +1 QUIT
- STRIP(X) ; strip off any ISBT-128 barcode identifier characters
- +1 SET X=$TRANSLATE(X,"=<>&%(","")
- +2 QUIT X
- BAR ; test bar code reader
- +1 NEW A,SR,SRABO,SRRH,SRPROMPT,X,Y
- SET SR=""
- +2 KILL DIR
- SET DIR(0)="FAO^1:20"
- SET DIR("A",1)=""
- SET (SRPROMPT,DIR("A"))=" => "
- +3 SET DIR("A",2)=" To use BAR CODE READER"
- +4 SET DIR("A",3)=" Pass reader wand over a GROUP-TYPE (ABO/Rh) label"
- +5 SET DIR("?",2)=" To test scanner, scan a GROUP-TYPE (ABO/Rh) label. Otherwise, press"
- +6 SET DIR("?",1)=""
- SET DIR("?")=" the Enter key."
- DO ^DIR
- KILL DIR
- if $DATA(DTOUT)!$DATA(DUOUT)!(X="")
- QUIT
- +7 WRITE $CHAR(13),$JUSTIFY("",79),$CHAR(13),SRPROMPT,"(Bar code)"
- +8 DO ISBTBG(X,.SRABO,.SRRH)
- IF SRABO]""
- Begin DoDot:1
- +9 SET SR=1
- SET SR(2)=""
- +10 WRITE " ",SRABO," ",SRRH
- End DoDot:1
- QUIT
- +11 SET X=$$STRIP(X)
- +12 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 SR=$LENGTH(X)-3
- SET SR(2)=$EXTRACT(X,1,SR)
- SET SR=SR+1
- QUIT
- +13 IF SR=""
- WRITE $CHAR(7),!!?28,"Not a GROUP-TYPE label",!?15,"Press <ENTER> key if BAR CODE READER is not used",!
- GOTO BAR
- +14 WRITE " ",$PIECE($TEXT(G+A),";",3)
- +15 QUIT
- ISBTBG(SRIN,SRBLABO,SRBLRH) ; check for ISBT-128 valid blood group and return ABO & Rh values
- +1 ; Valid codes are prefixed by "=%".
- +2 ;
- +3 ; INPUT : SRIN = input from Blood Group barcode label.
- +4 ; OUTPUT : SRBLABO (passed by reference) = ABO value
- +5 ; SRBLRH (passed by reference) = Rh value
- +6 ;
- +7 NEW Z
- SET (SRBLABO,SRBLRH)=""
- +8 if $LENGTH(SRIN)'>3
- QUIT
- +9 if $EXTRACT(SRIN,1,2)'="=%"
- QUIT
- +10 SET Z=$EXTRACT(SRIN,3,4)
- +11 SET SRBLABO=$SELECT(57<Z&(Z<66):"A POS",46<Z&(Z<55):"O POS",90<Z&(Z<99):"O NEG",1<Z&(Z<10):"A NEG",12<Z&(Z<21):"B NEG",68<Z&(Z<77):"B POS",23<Z&(Z<32):"AB NEG",79<Z&(Z<88):"AB POS",1:"")
- +12 if SRBLABO=""
- QUIT
- +13 SET SRBLRH=$PIECE(SRBLABO," ",2)
- +14 SET SRBLABO=$PIECE(SRBLABO," ")
- +15 QUIT
- ISBTUID(SRBLIN) ; Check for and display valid ISBT-128 Unit Id
- +1 ; Valid codes are prefixed by "="
- +2 ;
- +3 ; INPUT : SRBLIN = input from Unit Id barcode label.
- +4 ; OUTPUT : Boolean
- +5 ;
- +6 if $EXTRACT(SRBLIN,1,2)'?1"="1(1A,1N)
- QUIT 0
- +7 SET SRBLIN=$EXTRACT(SRBLIN,2,14)
- +8 ; make uppercase
- SET SRBLIN=$$UP^XLFSTR(SRBLIN)
- +9 WRITE $CHAR(13),$JUSTIFY("",79),$CHAR(13),SRPROMPT,?32,"(Bar code)"
- +10 DO EN^DDIOL("UNIT ID: "_SRBLIN,"","?46")
- +11 QUIT 1
- 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;