VBECA1 ;DALOI/PWC - APIS TO RETURN BLOOD BANK DATA FOR LAB ;10/12/00 13:57
;;2.0;VBEC;;Jun 05, 2015;Build 4
;
; Note: This routine supports data exchange with an FDA registered
; medical device. As such, it may not be changed in any way without
; prior written approval from the medical device manufacturer.
;
; Integration Agreements:
; Reference to FIND^DIC supported by IA #2051
; Reference to ^%DT supported by IA #10003
; Reference to GETS^DIQ() supported by IA #2056
;
QUIT
; ----------------------------------------------------------------
; Private Method Supports IA 3181
; ----------------------------------------------------------------
ABORH(PATID,PATNAM,PATDOB,PARENT) ;
; Return the ABO/Rh value for the DFN of the patient provided.
; A space will be between the values.
;
; Implement new VBECS API.
N IFN
D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
I '$G(IFN) Q -1
S ABORH=""
Q $$ABORH^VBECA1B(IFN,"ABORH")
;
;K LRERR,DIERR,ARR
;D GETS^DIQ(63,LRDFN_",",".05;.06","E","ARR","LRERR")
;S P5=ARR(63,LRDFN_",",.05,"E"),P6=ARR(63,LRDFN_",",.06,"E")
;S ANS=P5_" "_P6
;K ARR
;Q ANS
;
; ----------------------------------------------------------------
; Private Method Supports IA 3181
; ----------------------------------------------------------------
ABO(PATID,PATNAM,PATDOB,PARENT) ;
; Return the ABO value for the DFN of the patient provided.
;
; Implement new VBECS API.
N IFN
D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
I '$G(IFN) Q -1
S ABO=""
Q $$ABORH^VBECA1B(IFN,"ABO")
;
;K LRERR,DIERR,ARR
;D GETS^DIQ(63,LRDFN_",",".05","E","ARR","LRERR")
;S P5=ARR(63,LRDFN_",",.05,"E"),ANS=P5
;K ARR
;Q ANS
;
; ----------------------------------------------------------------
; Private Method Supports IA 3181
; ----------------------------------------------------------------
RH(PATID,PATNAM,PATDOB,PARENT) ;
; Return the Rh value for the DFN of the patient provided.
;
; Implement new VBECS API.
N IFN
D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
I '$G(IFN) Q -1
S RH=""
Q $$ABORH^VBECA1B(IFN,"RH")
;
;K LRERR,DIERR,ARR
;D GETS^DIQ(63,LRDFN_",",".06","E","ARR","LRERR")
;S P6=ARR(63,LRDFN_",",.06,"E"),ANS=P6
;K ARR
;Q ANS
;
; -------------------------------------------------------
; Deprecated Method - Removed from IA 3181
; -------------------------------------------------------
AGPRES(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Antigens Present
; Return an array of identified antigens and antigen comments for
; the DFN of the patient provided. If no antigens found, an empty
; array is returned ARR("AGPRES")="".
;
; ARR = the name of the array used to store antigens.
; Array will contain the name of the antigen and any antigen comments
; ARR("AGPRES",n) = Antigen ^ Antigen comment
;
;K ARR
;N LRDFN,A,I,X,P1,P2,P1A
;D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
;I 'LRDFN S ARR=-1 Q
;S A=0 F I=1:1 S A=$O(^LR(LRDFN,1,A)) Q:A="B"!(A="") D
;. S DATA=$G(^LR(LRDFN,1,A,0))
;. S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2)
;. S P1A=$P($G(^LAB(61.3,P1,0)),"^",1)
;. S ARR("AGPRES",I)=P1A_"^"_P2
;S:'$D(ARR) ARR("AGPRES")="" ;return empty array if none found
Q
;
; ----------------------------------------------------------------
; Private Method Supports IA 3181
; ----------------------------------------------------------------
ABID(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Antibodies Identified
; Return an array of identified antibodies and antibody comments for
; the DFN of the patient provided.
;
; ARR = the name of the array used to store antibodies.
; Array will contain the name of the antibody and any antibody comments
; ARR("ABID",n) = Antibody ^ Antibody comment
;
K ARR
N IFN
D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
I '$G(IFN) S ARR=-1 Q
D ABID^VBECA1B(IFN) Q
;
;S A=0 F I=1:1 S A=$O(^LR(LRDFN,1.7,A)) Q:A="" D
;. S DATA=$G(^LR(LRDFN,1.7,A,0))
;. S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2)
;. S P1A=$P($G(^LAB(61.3,P1,0)),"^",1)
;. S ARR("ABID",I)=P1A_"^"_P2
;S:'$D(ARR) ARR("ABID")="" ;return empty array if none found
;Q
;
; -------------------------------------------------------
; Deprecated Method - Removed from IA 3181
; -------------------------------------------------------
AGAB(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get RBC Antigens Absent
; Return an array of absent antigens and absent antigen comments for
; the DFN of the patient provided.
; ARR = the name of the array used to store absent antigens.
; Array will contain the name of the antigen and any antigen comments
; ARR("AGAB",n) = Absent Antigen ^ Absent Antigen comment
;
;K ARR
;N LRDFN,A,I,X,P1,P2,P1A,DATA
;D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
;I 'LRDFN S ARR=-1 Q
;S A=0 F I=1:1 S A=$O(^LR(LRDFN,1.5,A)) Q:A="" D
;. S DATA=$G(^LR(LRDFN,1.5,A,0))
;. S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2)
;. S P1A=$P($G(^LAB(61.3,P1,0)),"^",1)
;. S ARR("AGAB",I)=P1A_"^"_P2
;S:'$D(ARR) ARR("AGAB")="" ;return empty array if none found
Q
;
; ----------------------------------------------------------------
; Private Method Supports IA 3181
; ----------------------------------------------------------------
TRRX(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Transfusion Reactions
; Return an array of transfusion reactions for the DFN of the
; patient provided. If no transfusion reactions found, an
; empty array is returned ARR("TRRX")=""
;
; ARR = the name of the array used to store transfusion reactions.
; Array will contain both reactions where a particular unit or
; transfusion was determined to be the cause of the reaction, and
; those where no unit could be identified as being the cause of the
; reaction.
; Transaction Type is a pointer to Blood Bank Utility File #65.4
; ARR("TRRX",n) = Transfusion Date/Time ^ Transaction Type
;
; Implement new VBECS API.
K ARR
N IFN
D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
I '$G(IFN) S ARR=-1 Q
D TRRX^VBECA1B(IFN) Q
;
; get the reactions associated with a particular transfusion
;S (A,CNT)=0 F S A=$O(^LR(LRDFN,1.6,A)) Q:A="" D
;. S DATA=$G(^LR(LRDFN,1.6,A,0))
;. S P1=$P(DATA,"^",1),P11=$P(DATA,"^",11) Q:P11="" ;transaction type
;. S P11A=$S(P11'="":$P($G(^LAB(65.4,P11,0)),"^",1),1:"")
;. S CNT=CNT+1,ARR("TRRX",CNT)=P1_"^"_P11A D
;. . D FIND^DIC(66,,".02","A","`"_$P(DATA,"^",2),,,,,"VBECTRX")
;. . S ARR("TRRX",CNT)=ARR("TRRX",CNT)_"^"_VBECTRX("DILIST","ID",1,.02)_"^"_$P(DATA,"^",3) ;Added UNIT ID and COMPONENT
;. . 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)
;; now get the reactions NOT associated with a particular transfusion
;S A=0 F S A=$O(^LR(LRDFN,1.9,A)) Q:A="" D
;. S DATA=$G(^LR(LRDFN,1.9,A,0))
;. S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2) Q:P2="" ;transaction type
;. S P2A=$S(P2'="":$P($G(^LAB(65.4,P2,0)),"^",1),1:"")
;. S CNT=CNT+1,ARR("TRRX",CNT)=P1_"^"_P2A
;. 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)
;S:'$D(ARR) ARR("TRRX")="" ;return empty array if none found
Q
;
; -------------------------------------------------------
; Private Method supports IA 3181-H
; -------------------------------------------------------
BBCMT(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Blood Bank Comments
; Return an array of blood bank comments for the DFN of the patient
; provided.
; If no comments found, an empty array is returned ARR("BBCMT")="".
; ARR = the name of the array that will be used to store comments.
; Array will contain all the comment text.
; ARR("BBCMT",n) = Blood Bank Comment Text
;
K ARR
N LRDFN,A,I,P76
D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
I 'LRDFN S ARR=-1 Q
S A=0 F I=1:1 S A=$O(^LR(LRDFN,3,A)) Q:A="" D
. S P76=$G(^LR(LRDFN,3,A,0))
. S ARR("BBCMT",I)=P76
S:'$D(ARR) ARR("BBCMT")="" ;return empty array if none found
Q
;
; -------------------------------------------------------
; Deprecated Method - Removed from IA 3181
; -------------------------------------------------------
AUTO(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Available Autologous Units
; Return an array of available autologous units for the DFN of the
; patient provided. If no comments found, an empty array is returned
; ARR("AUTO")="".
;
; ARR = the name of the array that will store autologous units.
; Array will contain the component type and the expiration date.
; ARR("AUTO",n) = Component Type ^ Expiration Date
; Component Type is a pointer to Blood Product File (#66)
;
;K ARR
;N LRDFN,A,I,AU,AUT,CMP,COMP,CNT,DATA,EXPDT,EXP
;D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
;I 'LRDFN S ARR=-1 Q
;I '$D(^LRD(65,"AU",LRDFN)) S ARR("AUTO")="" Q ;no AP xref
;S (A,CNT)=0 F I=1:1 S A=$O(^LRD(65,"AU",LRDFN,A)) Q:A="" D
;. S AUT=$G(^LRD(65,A,4)) Q:$P(AUT,"^")'="" ; already dispositioned
;. S AU=$P(^LRD(65,A,8),"^",3) Q:AU'="A" ; autologous unit
;. S DATA=$G(^LRD(65,A,0)),CMP=$P(DATA,"^",4),EXPDT=$P(DATA,"^",6)
;. S COMP=$P($G(^LAB(66,CMP,0)),"^",1) ; ptr to blood product file
;. D EXPIRE(EXPDT) Q:EXP=1 ;unit is expired
;. S CNT=CNT+1,ARR("AUTO",CNT)=COMP_"^"_EXPDT
;S:'$D(ARR) ARR("AUTO")="" ;return empty array if none found
Q
;
EXPIRE(X) ; check if date has expired
S EXP=0,%DT="TXF" D ^%DT S X=Y K:Y<1 X
I $D(X) S X(1)=X,%DT="T",X="N" D ^%DT S X=X(1) D
. I $P(X,".")'>$P(Y,".") S EXP=1 Q ; Unit expired or expires today
. S EXP=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECA1 9847 printed Apr 09, 2024@21:46:05 Page 2
VBECA1 ;DALOI/PWC - APIS TO RETURN BLOOD BANK DATA FOR LAB ;10/12/00 13:57
+1 ;;2.0;VBEC;;Jun 05, 2015;Build 4
+2 ;
+3 ; Note: This routine supports data exchange with an FDA registered
+4 ; medical device. As such, it may not be changed in any way without
+5 ; prior written approval from the medical device manufacturer.
+6 ;
+7 ; Integration Agreements:
+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 QUIT
+13 ; ----------------------------------------------------------------
+14 ; Private Method Supports IA 3181
+15 ; ----------------------------------------------------------------
ABORH(PATID,PATNAM,PATDOB,PARENT) ;
+1 ; Return the ABO/Rh value for the DFN of the patient provided.
+2 ; A space will be between the values.
+3 ;
+4 ; Implement new VBECS API.
+5 NEW IFN
+6 ;pass DFN, return LRDFN or 0 if not found
DO PAT^VBECA1A
+7 IF '$GET(IFN)
QUIT -1
+8 SET ABORH=""
+9 QUIT $$ABORH^VBECA1B(IFN,"ABORH")
+10 ;
+11 ;K LRERR,DIERR,ARR
+12 ;D GETS^DIQ(63,LRDFN_",",".05;.06","E","ARR","LRERR")
+13 ;S P5=ARR(63,LRDFN_",",.05,"E"),P6=ARR(63,LRDFN_",",.06,"E")
+14 ;S ANS=P5_" "_P6
+15 ;K ARR
+16 ;Q ANS
+17 ;
+18 ; ----------------------------------------------------------------
+19 ; Private Method Supports IA 3181
+20 ; ----------------------------------------------------------------
ABO(PATID,PATNAM,PATDOB,PARENT) ;
+1 ; Return the ABO value for the DFN of the patient provided.
+2 ;
+3 ; Implement new VBECS API.
+4 NEW IFN
+5 ;pass DFN, return LRDFN or 0 if not found
DO PAT^VBECA1A
+6 IF '$GET(IFN)
QUIT -1
+7 SET ABO=""
+8 QUIT $$ABORH^VBECA1B(IFN,"ABO")
+9 ;
+10 ;K LRERR,DIERR,ARR
+11 ;D GETS^DIQ(63,LRDFN_",",".05","E","ARR","LRERR")
+12 ;S P5=ARR(63,LRDFN_",",.05,"E"),ANS=P5
+13 ;K ARR
+14 ;Q ANS
+15 ;
+16 ; ----------------------------------------------------------------
+17 ; Private Method Supports IA 3181
+18 ; ----------------------------------------------------------------
RH(PATID,PATNAM,PATDOB,PARENT) ;
+1 ; Return the Rh value for the DFN of the patient provided.
+2 ;
+3 ; Implement new VBECS API.
+4 NEW IFN
+5 ;pass DFN, return LRDFN or 0 if not found
DO PAT^VBECA1A
+6 IF '$GET(IFN)
QUIT -1
+7 SET RH=""
+8 QUIT $$ABORH^VBECA1B(IFN,"RH")
+9 ;
+10 ;K LRERR,DIERR,ARR
+11 ;D GETS^DIQ(63,LRDFN_",",".06","E","ARR","LRERR")
+12 ;S P6=ARR(63,LRDFN_",",.06,"E"),ANS=P6
+13 ;K ARR
+14 ;Q ANS
+15 ;
+16 ; -------------------------------------------------------
+17 ; Deprecated Method - Removed from IA 3181
+18 ; -------------------------------------------------------
AGPRES(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Antigens Present
+1 ; Return an array of identified antigens and antigen comments for
+2 ; the DFN of the patient provided. If no antigens found, an empty
+3 ; array is returned ARR("AGPRES")="".
+4 ;
+5 ; ARR = the name of the array used to store antigens.
+6 ; Array will contain the name of the antigen and any antigen comments
+7 ; ARR("AGPRES",n) = Antigen ^ Antigen comment
+8 ;
+9 ;K ARR
+10 ;N LRDFN,A,I,X,P1,P2,P1A
+11 ;D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
+12 ;I 'LRDFN S ARR=-1 Q
+13 ;S A=0 F I=1:1 S A=$O(^LR(LRDFN,1,A)) Q:A="B"!(A="") D
+14 ;. S DATA=$G(^LR(LRDFN,1,A,0))
+15 ;. S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2)
+16 ;. S P1A=$P($G(^LAB(61.3,P1,0)),"^",1)
+17 ;. S ARR("AGPRES",I)=P1A_"^"_P2
+18 ;S:'$D(ARR) ARR("AGPRES")="" ;return empty array if none found
+19 QUIT
+20 ;
+21 ; ----------------------------------------------------------------
+22 ; Private Method Supports IA 3181
+23 ; ----------------------------------------------------------------
ABID(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Antibodies Identified
+1 ; Return an array of identified antibodies and antibody comments for
+2 ; the DFN of the patient provided.
+3 ;
+4 ; ARR = the name of the array used to store antibodies.
+5 ; Array will contain the name of the antibody and any antibody comments
+6 ; ARR("ABID",n) = Antibody ^ Antibody comment
+7 ;
+8 KILL ARR
+9 NEW IFN
+10 ;pass DFN, return LRDFN or 0 if not found
DO PAT^VBECA1A
+11 IF '$GET(IFN)
SET ARR=-1
QUIT
+12 DO ABID^VBECA1B(IFN)
QUIT
+13 ;
+14 ;S A=0 F I=1:1 S A=$O(^LR(LRDFN,1.7,A)) Q:A="" D
+15 ;. S DATA=$G(^LR(LRDFN,1.7,A,0))
+16 ;. S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2)
+17 ;. S P1A=$P($G(^LAB(61.3,P1,0)),"^",1)
+18 ;. S ARR("ABID",I)=P1A_"^"_P2
+19 ;S:'$D(ARR) ARR("ABID")="" ;return empty array if none found
+20 ;Q
+21 ;
+22 ; -------------------------------------------------------
+23 ; Deprecated Method - Removed from IA 3181
+24 ; -------------------------------------------------------
AGAB(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get RBC Antigens Absent
+1 ; Return an array of absent antigens and absent antigen comments for
+2 ; the DFN of the patient provided.
+3 ; ARR = the name of the array used to store absent antigens.
+4 ; Array will contain the name of the antigen and any antigen comments
+5 ; ARR("AGAB",n) = Absent Antigen ^ Absent Antigen comment
+6 ;
+7 ;K ARR
+8 ;N LRDFN,A,I,X,P1,P2,P1A,DATA
+9 ;D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
+10 ;I 'LRDFN S ARR=-1 Q
+11 ;S A=0 F I=1:1 S A=$O(^LR(LRDFN,1.5,A)) Q:A="" D
+12 ;. S DATA=$G(^LR(LRDFN,1.5,A,0))
+13 ;. S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2)
+14 ;. S P1A=$P($G(^LAB(61.3,P1,0)),"^",1)
+15 ;. S ARR("AGAB",I)=P1A_"^"_P2
+16 ;S:'$D(ARR) ARR("AGAB")="" ;return empty array if none found
+17 QUIT
+18 ;
+19 ; ----------------------------------------------------------------
+20 ; Private Method Supports IA 3181
+21 ; ----------------------------------------------------------------
TRRX(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Transfusion Reactions
+1 ; Return an array of transfusion reactions for the DFN of the
+2 ; patient provided. If no transfusion reactions found, an
+3 ; empty array is returned ARR("TRRX")=""
+4 ;
+5 ; ARR = the name of the array used to store transfusion reactions.
+6 ; Array will contain both reactions where a particular unit or
+7 ; transfusion was determined to be the cause of the reaction, and
+8 ; those where no unit could be identified as being the cause of the
+9 ; reaction.
+10 ; Transaction Type is a pointer to Blood Bank Utility File #65.4
+11 ; ARR("TRRX",n) = Transfusion Date/Time ^ Transaction Type
+12 ;
+13 ; Implement new VBECS API.
+14 KILL ARR
+15 NEW IFN
+16 ;pass DFN, return LRDFN or 0 if not found
DO PAT^VBECA1A
+17 IF '$GET(IFN)
SET ARR=-1
QUIT
+18 DO TRRX^VBECA1B(IFN)
QUIT
+19 ;
+20 ; get the reactions associated with a particular transfusion
+21 ;S (A,CNT)=0 F S A=$O(^LR(LRDFN,1.6,A)) Q:A="" D
+22 ;. S DATA=$G(^LR(LRDFN,1.6,A,0))
+23 ;. S P1=$P(DATA,"^",1),P11=$P(DATA,"^",11) Q:P11="" ;transaction type
+24 ;. S P11A=$S(P11'="":$P($G(^LAB(65.4,P11,0)),"^",1),1:"")
+25 ;. S CNT=CNT+1,ARR("TRRX",CNT)=P1_"^"_P11A D
+26 ;. . D FIND^DIC(66,,".02","A","`"_$P(DATA,"^",2),,,,,"VBECTRX")
+27 ;. . S ARR("TRRX",CNT)=ARR("TRRX",CNT)_"^"_VBECTRX("DILIST","ID",1,.02)_"^"_$P(DATA,"^",3) ;Added UNIT ID and COMPONENT
+28 ;. . 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)
+29 ;; now get the reactions NOT associated with a particular transfusion
+30 ;S A=0 F S A=$O(^LR(LRDFN,1.9,A)) Q:A="" D
+31 ;. S DATA=$G(^LR(LRDFN,1.9,A,0))
+32 ;. S P1=$P(DATA,"^",1),P2=$P(DATA,"^",2) Q:P2="" ;transaction type
+33 ;. S P2A=$S(P2'="":$P($G(^LAB(65.4,P2,0)),"^",1),1:"")
+34 ;. S CNT=CNT+1,ARR("TRRX",CNT)=P1_"^"_P2A
+35 ;. 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)
+36 ;S:'$D(ARR) ARR("TRRX")="" ;return empty array if none found
+37 QUIT
+38 ;
+39 ; -------------------------------------------------------
+40 ; Private Method supports IA 3181-H
+41 ; -------------------------------------------------------
BBCMT(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Blood Bank Comments
+1 ; Return an array of blood bank comments for the DFN of the patient
+2 ; provided.
+3 ; If no comments found, an empty array is returned ARR("BBCMT")="".
+4 ; ARR = the name of the array that will be used to store comments.
+5 ; Array will contain all the comment text.
+6 ; ARR("BBCMT",n) = Blood Bank Comment Text
+7 ;
+8 KILL ARR
+9 NEW LRDFN,A,I,P76
+10 ;pass DFN, return LRDFN or 0 if not found
DO PAT^VBECA1A
+11 IF 'LRDFN
SET ARR=-1
QUIT
+12 SET A=0
FOR I=1:1
SET A=$ORDER(^LR(LRDFN,3,A))
if A=""
QUIT
Begin DoDot:1
+13 SET P76=$GET(^LR(LRDFN,3,A,0))
+14 SET ARR("BBCMT",I)=P76
End DoDot:1
+15 ;return empty array if none found
if '$DATA(ARR)
SET ARR("BBCMT")=""
+16 QUIT
+17 ;
+18 ; -------------------------------------------------------
+19 ; Deprecated Method - Removed from IA 3181
+20 ; -------------------------------------------------------
AUTO(PATID,PATNAM,PATDOB,PARENT,ARR) ; Get Available Autologous Units
+1 ; Return an array of available autologous units for the DFN of the
+2 ; patient provided. If no comments found, an empty array is returned
+3 ; ARR("AUTO")="".
+4 ;
+5 ; ARR = the name of the array that will store autologous units.
+6 ; Array will contain the component type and the expiration date.
+7 ; ARR("AUTO",n) = Component Type ^ Expiration Date
+8 ; Component Type is a pointer to Blood Product File (#66)
+9 ;
+10 ;K ARR
+11 ;N LRDFN,A,I,AU,AUT,CMP,COMP,CNT,DATA,EXPDT,EXP
+12 ;D PAT^VBECA1A ;pass DFN, return LRDFN or 0 if not found
+13 ;I 'LRDFN S ARR=-1 Q
+14 ;I '$D(^LRD(65,"AU",LRDFN)) S ARR("AUTO")="" Q ;no AP xref
+15 ;S (A,CNT)=0 F I=1:1 S A=$O(^LRD(65,"AU",LRDFN,A)) Q:A="" D
+16 ;. S AUT=$G(^LRD(65,A,4)) Q:$P(AUT,"^")'="" ; already dispositioned
+17 ;. S AU=$P(^LRD(65,A,8),"^",3) Q:AU'="A" ; autologous unit
+18 ;. S DATA=$G(^LRD(65,A,0)),CMP=$P(DATA,"^",4),EXPDT=$P(DATA,"^",6)
+19 ;. S COMP=$P($G(^LAB(66,CMP,0)),"^",1) ; ptr to blood product file
+20 ;. D EXPIRE(EXPDT) Q:EXP=1 ;unit is expired
+21 ;. S CNT=CNT+1,ARR("AUTO",CNT)=COMP_"^"_EXPDT
+22 ;S:'$D(ARR) ARR("AUTO")="" ;return empty array if none found
+23 QUIT
+24 ;
EXPIRE(X) ; check if date has expired
+1 SET EXP=0
SET %DT="TXF"
DO ^%DT
SET X=Y
if Y<1
KILL X
+2 IF $DATA(X)
SET X(1)=X
SET %DT="T"
SET X="N"
DO ^%DT
SET X=X(1)
Begin DoDot:1
+3 ; Unit expired or expires today
IF $PIECE(X,".")'>$PIECE(Y,".")
SET EXP=1
QUIT
+4 SET EXP=0
End DoDot:1
+5 QUIT
