source: FOIAVistA/trunk/r/VBECS-VBEC/VBECA1.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1VBECA1 ;DALOI/PWC - APIS TO RETURN BLOOD BANK DATA FOR LAB ;10/12/00 13:57
2 ;;0.5;VBECS;**294**;Sep 6, 2000
3 ; This routine retrieves data maintained by a regulated medical
4 ; device. The routine must not be modified by anyone other than the
5 ; device manufacturer.
6 ; This routine is not intended to be invoked by name
7 QUIT
8 ;Reference to FIND^DIC supported by IA #2051
9 ;Reference to ^%DT supported by IA #10003
10 ;Reference to GETS^DIQ() supported by IA #2056
11 ;
12 ; This routine is called by other packages to access blood bank data
13 ;
14ABORH(PATID,PATNAM,PATDOB,PARENT) ;
15 ; Return the ABO/Rh value stored in file 63, fields .05 & .06
16 ; for the DFN of the patient provided. A space will be between
17 ; values .05 and .06.
18 ;
19 N LRDFN,P5,P6
20 D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
21 I 'LRDFN Q -1
22 K LRERR,DIERR,ARR
23 D GETS^DIQ(63,LRDFN_",",".05;.06","E","ARR","LRERR")
24 S P5=ARR(63,LRDFN_",",.05,"E"),P6=ARR(63,LRDFN_",",.06,"E")
25 S ANS=P5_" "_P6
26 K ARR
27 Q ANS
28 ;
29ABO(PATID,PATNAM,PATDOB,PARENT) ;
30 ; Return the ABO value stored in file 63, fields .05 for the DFN
31 ; of the patient provided.
32 ;
33 N LRDFN,P5
34 D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
35 I 'LRDFN Q -1
36 K LRERR,DIERR,ARR
37 D GETS^DIQ(63,LRDFN_",",".05","E","ARR","LRERR")
38 S P5=ARR(63,LRDFN_",",.05,"E"),ANS=P5
39 K ARR
40 Q ANS
41 ;
42RH(PATID,PATNAM,PATDOB,PARENT) ;
43 ; Return the Rh value stored in file 63, fields .06 for the DFN
44 ; of the patient provided.
45 ;
46 N LRDFN,P6
47 D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
48 I 'LRDFN Q -1
49 K LRERR,DIERR,ARR
50 D GETS^DIQ(63,LRDFN_",",".06","E","ARR","LRERR")
51 S P6=ARR(63,LRDFN_",",.06,"E"),ANS=P6
52 K ARR
53 Q ANS
54 ;
55AGPRES(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Antigens Present
56 ; Return an array of identified antigens and antigen comments for
57 ; the DFN of the patient provided. If no antigens found, an empty
58 ; array is returned ARR("AGPRES")="".
59 ; The antigens are found in file 63.13 (multiple), fields .01 and .02.
60 ; ^LR(LRDFN,1
61 ; Antigens is a pointer to Function Field file #61.3.
62 ; ARR = the name of the array used to store antigens.
63 ; Array will contain the name of the antigen and any antigen comments
64 ; ARR("AGPRES",n) = Antigen ^ Antigen comment
65 ;
66 K ARR
67 N LRDFN,A,I,X,P1,P2,P1A
68 D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
69 I 'LRDFN S ARR=-1 Q
70 S A=0 F I=1:1 S A=$O(^LR(LRDFN,1,A)) Q:A="B"!(A="") D
71 . S DATA=$G(^LR(LRDFN,1,A,0))
72 . S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2)
73 . S P1A=$P($G(^LAB(61.3,P1,0)),"^",1)
74 . S ARR("AGPRES",I)=P1A_"^"_P2
75 S:'$D(ARR) ARR("AGPRES")="" ;return empty array if none found
76 Q
77 ;
78ABID(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Antiobodies Identified
79 ; Return an array of identified antibodies and antibody comments for
80 ; the DFN of the patient provided. If no antibodies found, an empty
81 ; array is returned ARR("ABID")="".
82 ; The antibodies are found in file 63.075, fields .01 and .02.
83 ; ^LR(LRDFN,1.7
84 ; Antibodies is a pointer to Function Field file #61.3.
85 ; ARR = the name of the array used to store antibodies.
86 ; Array will contain the name of the antibody and any antibody comments
87 ; ARR("ABID",n) = Antibody ^ Antibody comment
88 ;
89 K ARR
90 N LRDFN,A,I,X,P2,P2,P1A
91 D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
92 I 'LRDFN S ARR=-1 Q
93 S A=0 F I=1:1 S A=$O(^LR(LRDFN,1.7,A)) Q:A="" D
94 . S DATA=$G(^LR(LRDFN,1.7,A,0))
95 . S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2)
96 . S P1A=$P($G(^LAB(61.3,P1,0)),"^",1)
97 . S ARR("ABID",I)=P1A_"^"_P2
98 S:'$D(ARR) ARR("ABID")="" ;return empty array if none found
99 Q
100 ;
101AGAB(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get RBC Antigens Absent
102 ; Return an array of absent antigens and absent antigen comments for
103 ; the DFN of the patient provided. If no records found, an empty
104 ; array is returned ARR("AGAB")="".
105 ; The absent antigens are found in file 63.016, fields .01 and .02.\
106 ; ^LR(LRDFN,1.5
107 ; Absent antigen is a pointer to Function Field file #61.3.
108 ; ARR = the name of the array used to store absent antigens.
109 ; Array will contain the name of the antigen and any antigen comments
110 ; ARR("AGAB",n) = Absent Antigen ^ Absent Antigen comment
111 ;
112 K ARR
113 N LRDFN,A,I,X,P1,P2,P1A,DATA
114 D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
115 I 'LRDFN S ARR=-1 Q
116 S A=0 F I=1:1 S A=$O(^LR(LRDFN,1.5,A)) Q:A="" D
117 . S DATA=$G(^LR(LRDFN,1.5,A,0))
118 . S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2)
119 . S P1A=$P($G(^LAB(61.3,P1,0)),"^",1)
120 . S ARR("AGAB",I)=P1A_"^"_P2
121 S:'$D(ARR) ARR("AGAB")="" ;return empty array if none found
122 Q
123 ;
124TRRX(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Transfusion Reactions
125 ; Return an array of transfusion reactions for the DFN of the
126 ; patient provided. If no transfusion reactions found, an
127 ; empty array is returned ARR("TRRX")'=""
128 ; The transfusion reactions associated with a particular transfusion
129 ; episode are found in file #63.017, fields .01 and .11.
130 ; ^LR(LRDFN,1.6
131 ; Transfusion reactions that could not be associated with a particular
132 ; transfusion are found in file #63.0171, fields .01 & .02.
133 ; ^LR(LRDFN,1.9
134 ;
135 ; ARR = the name of the array used to store transfusion reactions.
136 ; Array will contain both reactions where a particular unit or
137 ; transfusion was determined to be the cause of the reaction, and
138 ; those where no unit could be identified as being the cause of the
139 ; reaction.
140 ; Transaction Type is a pointer to Blood Bank Utility File #65.4
141 ; ARR("TRRX",n) = Transfusion Date/Time ^ Transaction Type
142 ;
143 K ARR
144 N LRDFN,A,P1,P2,P1A,P11,P11A,P2A,CNT,DATA
145 D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
146 I 'LRDFN S ARR=-1 Q
147 ; get the reactions associated with a particular transfusion
148 S (A,CNT)=0 F S A=$O(^LR(LRDFN,1.6,A)) Q:A="" D
149 . S DATA=$G(^LR(LRDFN,1.6,A,0))
150 . S P1=$P(DATA,"^",1),P11=$P(DATA,"^",11) Q:P11="" ;transaction type
151 . S P11A=$S(P11'="":$P($G(^LAB(65.4,P11,0)),"^",1),1:"")
152 . S CNT=CNT+1,ARR("TRRX",CNT)=P1_"^"_P11A D
153 . . D FIND^DIC(66,,".02","A","`"_$P(DATA,"^",2),,,,,"VBECTRX")
154 . . S ARR("TRRX",CNT)=ARR("TRRX",CNT)_"^"_VBECTRX("DILIST","ID",1,.02)_"^"_$P(DATA,"^",3) ;Added UNIT ID and COMPONENT
155 . . S CMT=0 F S CMT=$O(^LR(LRDFN,1.6,A,1,CMT)) Q:'CMT S ARR("TRRX",CNT,CMT)=^LR(LRDFN,1.6,A,1,CMT,0)
156 ; now get the reactions NOT associated with a particular transfusion
157 S A=0 F S A=$O(^LR(LRDFN,1.9,A)) Q:A="" D
158 . S DATA=$G(^LR(LRDFN,1.9,A,0))
159 . S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2) Q:P2="" ;transaction type
160 . S P2A=$S(P2'="":$P($G(^LAB(65.4,P2,0)),"^",1),1:"")
161 . S CNT=CNT+1,ARR("TRRX",CNT)=P1_"^"_P2A
162 . S CMT=0 F S CMT=$O(^LR(LRDFN,1.9,A,1,CMT)) Q:'CMT S ARR("TRRX",CNT,CMT)=^LR(LRDFN,1.9,A,1,CMT,0)
163 S:'$D(ARR) ARR("TRRX")="" ;return empty array if none found
164 Q
165 ;
166BBCMT(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Blood Bank Comments
167 ; Return an array of blood bank comments for the DFN of the patient
168 ; provided.
169 ; If no comments found, an empty array is returned ARR("BBCMT")="".
170 ; The comments are found in file 63, fields .076.
171 ; ^LR(LRDFN,3
172 ; ARR = the name of the array that will be used to store comments.
173 ; Array will contain all the comment text.
174 ; ARR("BBCMT",n) = Blood Bank Comment Text
175 ;
176 K ARR
177 N LRDFN,A,I,P76
178 D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
179 I 'LRDFN S ARR=-1 Q
180 S A=0 F I=1:1 S A=$O(^LR(LRDFN,3,A)) Q:A="" D
181 . S P76=$G(^LR(LRDFN,3,A,0))
182 . S ARR("BBCMT",I)=P76
183 S:'$D(ARR) ARR("BBCMT")="" ;return empty array if none found
184 Q
185AUTO(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Available Autologous Units
186 ; Return an array of available autologous units for the DFN of the
187 ; patient provided. If no comments found, an empty array is returned
188 ; ARR("AUTO")="". The autologous units are found in file 65 (Blood
189 ; Inventory), fields 8.3. First we will check to see if unit has not
190 ; been dispositioned, therefore can be used for crossmatching
191 ; ("AU" level). Next check if unit is autologous, then the array
192 ; will return the component type (file 65, field .04) and
193 ; expiration date (file 65, field .06). If expiration date has
194 ; expired, or will expire today, then the array is sent back with
195 ; the Component Type ^ "EXPIRED" (literal text)
196 ; ARR = the name of the array that will store autologous units.
197 ; Array will contain the component type and the expiration date.
198 ; ARR("AUTO",n) = Component Type ^ Expiration Date
199 ; Component Type is a pointer to Blood Product File (#66)
200 ;
201 K ARR
202 N LRDFN,A,I,AU,AUT,CMP,COMP,CNT,DATA,EXPDT,EXP
203 D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
204 I 'LRDFN S ARR=-1 Q
205 I '$D(^LRD(65,"AU",LRDFN)) S ARR("AUTO")="" Q ;no AP xref
206 S (A,CNT)=0 F I=1:1 S A=$O(^LRD(65,"AU",LRDFN,A)) Q:A="" D
207 . S AUT=$G(^LRD(65,A,4)) Q:$P(AUT,"^")'="" ; already dispositioned
208 . S AU=$P(^LRD(65,A,8),"^",3) Q:AU'="A" ; autologous unit
209 . S DATA=$G(^LRD(65,A,0)),CMP=$P(DATA,"^",4),EXPDT=$P(DATA,"^",6)
210 . S COMP=$P($G(^LAB(66,CMP,0)),"^",1) ; ptr to blood product file
211 . D EXPIRE(EXPDT) Q:EXP=1 ;unit is expired
212 . S CNT=CNT+1,ARR("AUTO",CNT)=COMP_"^"_EXPDT
213 S:'$D(ARR) ARR("AUTO")="" ;return empty array if none found
214 Q
215 ;
216EXPIRE(X) ; check if date has expired
217 S EXP=0,%DT="TXF" D ^%DT S X=Y K:Y<1 X
218 I $D(X) S X(1)=X,%DT="T",X="N" D ^%DT S X=X(1) D
219 . I $P(X,".")'>$P(Y,".") S EXP=1 Q ; Unit expired or expires today
220 . S EXP=0
221 Q
Note: See TracBrowser for help on using the repository browser.