source: WorldVistAEHR/trunk/r/SURGERY-SR/SRBL.m@ 1211

Last change on this file since 1211 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.3 KB
Line 
1SRBL ;BIR/ADM - BLOOD PRODUCT VERIFICATION FOR VBECS ;09/01/05
2 ;;3.0; Surgery ;**148**;24 Jun 93
3 ;
4 ; Reference to AVUNIT^VBECA1B supported by DBIA #4629
5 ;
6SCAN D BAR ; test bar code reader
7 S SRQ=0,DFN=$P(^SRF(SRTN,0),"^") K ^TMP("SRBL",$J)
8 D AVUNIT^VBECA1B("SRBL",DFN) ; get list of units available for the patient
9TST K DIR S DIR(0)="FA^1:50",(SRPROMPT,DIR("A"))="Enter Blood Product Identifier: "
10 S DIR("?")="Enter or scan the Blood Product Unit Id" D ^DIR K DIR G END:$D(DTOUT)!$D(DUOUT)
11 D CODA,MATCH I 'SRMATCH G SRNO
12 I SRMATCH=1 S SRY=SRMATCH D SRYES Q
13 D LIST I SRQ G END
14 S SRY=Y D SRYES
15 Q
16LIST W ! S Y=^TMP("SRBL",$J,0),Z=$P(Y,"^",7),SRSSN=$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,12)
17 S SRNAME=$P(Y,"^",5)_","_$P(Y,"^",4)_" "_SRSSN
18 S (SRI,SRZ)=0 F S SRZ=$O(SRBL(SRZ)) Q:'SRZ D
19 .S Z=SRBL(SRZ),SRPROD=$P(Z,"^",4),X=$P(Z,"^",2) D ^%DT S SREXP=Y
20 .W !!," ",SRZ_") Unit ID: ",SRUID,?45,SRPROD
21 .W !,?4,"Patient: ",SRNAME,?45,"Expiration Date: " S Y=SREXP D DD^%DT W Y
22 .S SRI=SRI+1
23 W ! K DIR S DIR(0)="NO^1:"_SRI,DIR("A")="Select the blood product matching the unit label"
24 D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRQ=1 Q
25 S SRY=Y
26 Q
27MATCH ; retrieve matching units from list of available units
28 S (SRIDT,SRMATCH)=0 F S SRIDT=$O(^TMP("SRBL",$J,SRIDT)) Q:'SRIDT D
29 .S X=^TMP("SRBL",$J,SRIDT)
30 .I $P(X,"^",3)=SRUID S SRMATCH=SRMATCH+1,SRBL(SRMATCH)=X
31 Q
32CODA ; interpret Codabar barcodes used to label the Unit ID of blood component
33 I $$ISBTUID(.X) S SRUID=X Q
34 S SRUID=$$STRIP(X)
35 W ?45,"UNIT ID: ",SRUID
36 Q
37SRYES S X=$P(SRBL(SRY),"^",2) D ^%DT I Y<DT D D ASK Q
38 .I SRMATCH=1 D LIST
39 .W !!,?30,"**WARNING**",!!,"Today's date exceeds the blood product expiration date.",!
40 W !!!,?25,"No Discrepancies Found",!!! K DIR S DIR(0)="FOA",DIR("A")="Press RETURN to continue" D ^DIR G END
41SRNO W !!,?30,"**WARNING**",!!
42 W ?5,"There is no record that this unit has been assigned to this patient."
43 W !!,?8," Please recheck the patient and blood product IDs.",!!
44ASK 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
45END K ^TMP("SRBL",$J),DIR,SR,SRBL,SREXP,SRI,SRIDT,SRMATCH,SRNAME,SRPROD,SRPROMPT,SRQ,SRSSN,SRUID,SRY,SRZ,X,Y,Z
46 Q
47STRIP(X) ; strip off any ISBT-128 barcode identifier characters
48 S X=$TR(X,"=<>&%(","")
49 Q X
50BAR ; test bar code reader
51 N A,SR,SRABO,SRRH,SRPROMPT,X,Y S SR=""
52 K DIR S DIR(0)="FAO^1:20" S DIR("A",1)="",(SRPROMPT,DIR("A"))=" => "
53 S DIR("A",2)=" To use BAR CODE READER"
54 S DIR("A",3)=" Pass reader wand over a GROUP-TYPE (ABO/Rh) label"
55 S DIR("?",2)=" To test scanner, scan a GROUP-TYPE (ABO/Rh) label. Otherwise, press"
56 S DIR("?",1)="",DIR("?")=" the Enter key." D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT)!(X="")
57 W $C(13),$J("",79),$C(13),SRPROMPT,"(Bar code)"
58 D ISBTBG(X,.SRABO,.SRRH) I SRABO]"" D Q
59 .S SR=1,SR(2)=""
60 .W " ",SRABO," ",SRRH
61 S X=$$STRIP(X)
62 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
63 I SR="" W $C(7),!!?28,"Not a GROUP-TYPE label",!?15,"Press <ENTER> key if BAR CODE READER is not used",! G BAR
64 W " ",$P($T(G+A),";",3)
65 Q
66ISBTBG(SRIN,SRBLABO,SRBLRH) ; check for ISBT-128 valid blood group and return ABO & Rh values
67 ; Valid codes are prefixed by "=%".
68 ;
69 ; INPUT : SRIN = input from Blood Group barcode label.
70 ; OUTPUT : SRBLABO (passed by reference) = ABO value
71 ; SRBLRH (passed by reference) = Rh value
72 ;
73 N Z S (SRBLABO,SRBLRH)=""
74 Q:$L(SRIN)'>3
75 Q:$E(SRIN,1,2)'="=%"
76 S Z=$E(SRIN,3,4)
77 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:"")
78 Q:SRBLABO=""
79 S SRBLRH=$P(SRBLABO," ",2)
80 S SRBLABO=$P(SRBLABO," ")
81 Q
82ISBTUID(SRBLIN) ; Check for and display valid ISBT-128 Unit Id
83 ; Valid codes are prefixed by "="
84 ;
85 ; INPUT : SRBLIN = input from Unit Id barcode label.
86 ; OUTPUT : Boolean
87 ;
88 Q:$E(SRBLIN,1,2)'?1"="1(1A,1N) 0
89 S SRBLIN=$E(SRBLIN,2,14)
90 S SRBLIN=$$UP^XLFSTR(SRBLIN) ; make uppercase
91 W $C(13),$J("",79),$C(13),SRPROMPT,?32,"(Bar code)"
92 D EN^DDIOL("UNIT ID: "_SRBLIN,"","?46")
93 Q 1
94G ;;
9551 ;;O POS;510
9662 ;;A POS;620
9773 ;;B POS;730
9884 ;;AB POS;840
9995 ;;O NEG;950
1006 ;;A NEG;060
10117 ;;B NEG;170
10228 ;;AB NEG;280
10355 ;;O;550
10466 ;;A;660
10577 ;;B;770
10688 ;;AB;880
107 ;;NA NA;
Note: See TracBrowser for help on using the repository browser.