- 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 Feb 19, 2025@00:10:11 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