- VBECA4 ;HINES OI/REL-APIs for Health Summary ;10/12/00 14:02
- ;;2.0;VBEC;**8**;Jun 05, 2015;Build 27
- ;
- ; 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:
- ; Call to $$FMTE^XLFDT is supported by IA: 10103
- ; Call to EN^DIQ is supported by IA: 10004
- ; Call to $$NS^XUAF4 is supported by IA: 2171
- ; Reference to $$LRDFN^LR7OR1 supported by IA #2503
- ;
- QUIT
- ;
- ; ----------------------------------------------------------------
- ; Private Method Supports IA 3176
- ; ----------------------------------------------------------------
- TRAN(DFN,TMPLOC,GMTS1,GMTS2) ; Get Transfusion Data for Health Summary
- ; Input variables:
- ; DFN = Internal number of patient
- ; TMPLOC = Node in ^TMP to be used for output data array
- ; GMTS1 = Inverse end date of search
- ; GMTS2 = Inverse start date of search
- ;
- ; Output is data array:
- ; ^TMP(TMPLOC,$J,n)
- N LRDFN,IDT,CNTR,TR,PN,PRODUCT,UNITS,TDT,ITDT,ARR
- Q:$G(TMPLOC)=""
- K ^TMP(TMPLOC,$J)
- Q:'$G(DFN)
- S:'$G(GMTS1) GMTS1=5555555 S:'$G(GMTS2) GMTS2=9999999
- ;
- D TRAN^VBECA1B(DFN)
- S IDT=GMTS1-1 F S IDT=$O(ARR(IDT)) Q:+IDT'>0!(IDT>GMTS2) D
- . S ^TMP(TMPLOC,$J,IDT)=ARR(IDT)
- . S ^TMP(TMPLOC,$J,$P($P(ARR(IDT),"\",2),";"))=ARR($P($P(ARR(IDT),"\",2),";"))
- Q
- ;
- S LRDFN=$$LRDFN^LR7OR1(DFN) Q:'LRDFN
- S IDT=GMTS1-1 F S IDT=$O(^LR(LRDFN,1.6,IDT)) Q:+IDT'>0!(IDT>GMTS2) D
- . S TR=$G(^LR(LRDFN,1.6,IDT,0)) D SET
- S IDT=0 F S IDT=$O(CNTR(IDT)) Q:+IDT'>0 D
- . S ^TMP(TMPLOC,$J,IDT)=9999999-IDT_U
- . S PN=0 F S PN=$O(CNTR(IDT,PN)) Q:PN'>0 D
- . . S PRODUCT=$G(^LAB(66,+PN,0)),^TMP(TMPLOC,$J,$P(PRODUCT,U,2))=$P(PRODUCT,U)
- . . S ^TMP(TMPLOC,$J,IDT)=^TMP(TMPLOC,$J,IDT)_CNTR(IDT,PN)_"\"_$P(PRODUCT,U,2)_";"
- Q
- ; ------------------------------------------------------------------
- ; Private Method Supports IA 3177
- ; ------------------------------------------------------------------
- AVUNIT(DFN,TMPLOC,GMTS1,GMTS2,GMTSNDM) ; Get Available Units for Health Summary
- ; Input variables:
- ; DFN = Internal number of patient
- ; TMPLOC = Node in ^TMP to be used for output data array
- ; GMTS1 = Inverse end date of search
- ; GMTS2 = Inverse start date of search
- ; GMTSNDM = Maximum number to be extracted
- ;
- ; Output is data array:
- ; ^TMP(TMPLOC,$J,n)
- N LRDFN,IDT,UN,CNT,ABO,ADT,COMP,DTYP,EDT,EFLG,GMI,RH,UDIV,UID,ULOC,VOL,ARR
- Q:$G(TMPLOC)=""
- K ^TMP(TMPLOC,$J)
- Q:'$G(DFN)
- S:'$G(GMTS1) GMTS1=5555555 S:'$G(GMTS2) GMTS2=9999999 S:'$G(GMTSNDM) GMTSNDM=999
- ; VBECS Implementation
- D AVUNIT^VBECA1B("AVUNIT",DFN)
- Q:'$D(^TMP("AVUNIT",$J))
- S IDT=GMTS1-1+.0001 F S IDT=$O(^TMP("AVUNIT",$J,IDT)) Q:+IDT'>0!(IDT>GMTS2) D
- . S ^TMP(TMPLOC,$J,0)=^TMP("AVUNIT",$J,0)
- . S ^TMP(TMPLOC,$J,IDT)=^TMP("AVUNIT",$J,IDT)
- Q
- ;
- S LRDFN=$$LRDFN^LR7OR1(DFN) Q:'LRDFN
- I $L($P(^LR(LRDFN,0),U,5,6)) S ^TMP(TMPLOC,$J,0)=$P(^(0),U,5)_U_$P(^(0),U,6)
- S UN="",CNT=0 F S UN=$O(^LRD(65,"AP",LRDFN,UN)) Q:UN=""!(CNT'<GMTSNDM) D BASET
- ;K:'CNT ^TMP(TMPLOC,$J)
- Q
- BASET ; Sets ^TMP with data elements
- S (EFLG,DTYP,ULOC)=""
- S UID=$P(^LRD(65,UN,0),U),EDT=$P(^(0),U,6),ABO=$P(^(0),U,7),RH=$P(^(0),U,8),VOL=$P(^(0),U,11),COMP=$P(^LAB(66,$P(^LRD(65,UN,0),U,4),0),U)
- S ADT=$P(^LRD(65,UN,2,LRDFN,0),U,2)
- S UDIV=$P(^LRD(65,UN,0),U,16),UDIV=$$NS^XUAF4(UDIV),UDIV=$P(UDIV,"^",1) ;Gets division unit is located at
- I $D(^LRD(65,UN,8)) D
- . S DIC=65,DIQ="DON",DIQ(0)="E",DR=8.3,DA=UN D EN^DIQ1
- . S:$D(DON) DTYP=DON(65,UN,8.3,"E") K DA,DIC,DIQ,DON,DR Q
- S GMI=$O(^LRD(65,UN,3,0)) I +GMI>0 D
- . S ULOC=$P($G(^LRD(65,UN,3,GMI,0)),U,4)
- ; If unit will expire w/in 48 hrs, flag with "*"; w/in 24 hrs, flag with "**"
- I EDT>DT S EFLG=$S(EDT-DT<2:"*",EDT-DT<1:"**",1:"")
- S IDT=9999999-ADT
- I $S(IDT<GMTS1:1,IDT>GMTS2:1,EDT<DT:1,1:0) Q
- S EDT=$TR($$FMTE^XLFDT(EDT,"5DZ"),"@"," ")
- F Q:'$D(^TMP(TMPLOC,$J,IDT)) S IDT=IDT+.0001
- S ^TMP(TMPLOC,$J,IDT)=EFLG_U_EDT_U_UID_U_COMP_U_VOL_U_ABO_U_RH_U_DTYP_U_UDIV_U_ULOC
- S CNT=CNT+1
- Q
- SET ; Sets CNTR w/appropriate data
- S TDT=9999999-IDT,ITDT=9999999-$P(TDT,".")
- S UNITS=+$P(TR,U,7) S:UNITS'>0 UNITS=1
- S CNTR(ITDT,+$P(TR,U,2))=+$G(CNTR(ITDT,+$P(TR,U,2)))+UNITS
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECA4 4334 printed Feb 19, 2025@00:10:19 Page 2
- VBECA4 ;HINES OI/REL-APIs for Health Summary ;10/12/00 14:02
- +1 ;;2.0;VBEC;**8**;Jun 05, 2015;Build 27
- +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 ; Call to $$FMTE^XLFDT is supported by IA: 10103
- +9 ; Call to EN^DIQ is supported by IA: 10004
- +10 ; Call to $$NS^XUAF4 is supported by IA: 2171
- +11 ; Reference to $$LRDFN^LR7OR1 supported by IA #2503
- +12 ;
- +13 QUIT
- +14 ;
- +15 ; ----------------------------------------------------------------
- +16 ; Private Method Supports IA 3176
- +17 ; ----------------------------------------------------------------
- TRAN(DFN,TMPLOC,GMTS1,GMTS2) ; Get Transfusion Data for Health Summary
- +1 ; Input variables:
- +2 ; DFN = Internal number of patient
- +3 ; TMPLOC = Node in ^TMP to be used for output data array
- +4 ; GMTS1 = Inverse end date of search
- +5 ; GMTS2 = Inverse start date of search
- +6 ;
- +7 ; Output is data array:
- +8 ; ^TMP(TMPLOC,$J,n)
- +9 NEW LRDFN,IDT,CNTR,TR,PN,PRODUCT,UNITS,TDT,ITDT,ARR
- +10 if $GET(TMPLOC)=""
- QUIT
- +11 KILL ^TMP(TMPLOC,$JOB)
- +12 if '$GET(DFN)
- QUIT
- +13 if '$GET(GMTS1)
- SET GMTS1=5555555
- if '$GET(GMTS2)
- SET GMTS2=9999999
- +14 ;
- +15 DO TRAN^VBECA1B(DFN)
- +16 SET IDT=GMTS1-1
- FOR
- SET IDT=$ORDER(ARR(IDT))
- if +IDT'>0!(IDT>GMTS2)
- QUIT
- Begin DoDot:1
- +17 SET ^TMP(TMPLOC,$JOB,IDT)=ARR(IDT)
- +18 SET ^TMP(TMPLOC,$JOB,$PIECE($PIECE(ARR(IDT),"\",2),";"))=ARR($PIECE($PIECE(ARR(IDT),"\",2),";"))
- End DoDot:1
- +19 QUIT
- +20 ;
- +21 SET LRDFN=$$LRDFN^LR7OR1(DFN)
- if 'LRDFN
- QUIT
- +22 SET IDT=GMTS1-1
- FOR
- SET IDT=$ORDER(^LR(LRDFN,1.6,IDT))
- if +IDT'>0!(IDT>GMTS2)
- QUIT
- Begin DoDot:1
- +23 SET TR=$GET(^LR(LRDFN,1.6,IDT,0))
- DO SET
- End DoDot:1
- +24 SET IDT=0
- FOR
- SET IDT=$ORDER(CNTR(IDT))
- if +IDT'>0
- QUIT
- Begin DoDot:1
- +25 SET ^TMP(TMPLOC,$JOB,IDT)=9999999-IDT_U
- +26 SET PN=0
- FOR
- SET PN=$ORDER(CNTR(IDT,PN))
- if PN'>0
- QUIT
- Begin DoDot:2
- +27 SET PRODUCT=$GET(^LAB(66,+PN,0))
- SET ^TMP(TMPLOC,$JOB,$PIECE(PRODUCT,U,2))=$PIECE(PRODUCT,U)
- +28 SET ^TMP(TMPLOC,$JOB,IDT)=^TMP(TMPLOC,$JOB,IDT)_CNTR(IDT,PN)_"\"_$PIECE(PRODUCT,U,2)_";"
- End DoDot:2
- End DoDot:1
- +29 QUIT
- +30 ; ------------------------------------------------------------------
- +31 ; Private Method Supports IA 3177
- +32 ; ------------------------------------------------------------------
- AVUNIT(DFN,TMPLOC,GMTS1,GMTS2,GMTSNDM) ; Get Available Units for Health Summary
- +1 ; Input variables:
- +2 ; DFN = Internal number of patient
- +3 ; TMPLOC = Node in ^TMP to be used for output data array
- +4 ; GMTS1 = Inverse end date of search
- +5 ; GMTS2 = Inverse start date of search
- +6 ; GMTSNDM = Maximum number to be extracted
- +7 ;
- +8 ; Output is data array:
- +9 ; ^TMP(TMPLOC,$J,n)
- +10 NEW LRDFN,IDT,UN,CNT,ABO,ADT,COMP,DTYP,EDT,EFLG,GMI,RH,UDIV,UID,ULOC,VOL,ARR
- +11 if $GET(TMPLOC)=""
- QUIT
- +12 KILL ^TMP(TMPLOC,$JOB)
- +13 if '$GET(DFN)
- QUIT
- +14 if '$GET(GMTS1)
- SET GMTS1=5555555
- if '$GET(GMTS2)
- SET GMTS2=9999999
- if '$GET(GMTSNDM)
- SET GMTSNDM=999
- +15 ; VBECS Implementation
- +16 DO AVUNIT^VBECA1B("AVUNIT",DFN)
- +17 if '$DATA(^TMP("AVUNIT",$JOB))
- QUIT
- +18 SET IDT=GMTS1-1+.0001
- FOR
- SET IDT=$ORDER(^TMP("AVUNIT",$JOB,IDT))
- if +IDT'>0!(IDT>GMTS2)
- QUIT
- Begin DoDot:1
- +19 SET ^TMP(TMPLOC,$JOB,0)=^TMP("AVUNIT",$JOB,0)
- +20 SET ^TMP(TMPLOC,$JOB,IDT)=^TMP("AVUNIT",$JOB,IDT)
- End DoDot:1
- +21 QUIT
- +22 ;
- +23 SET LRDFN=$$LRDFN^LR7OR1(DFN)
- if 'LRDFN
- QUIT
- +24 IF $LENGTH($PIECE(^LR(LRDFN,0),U,5,6))
- SET ^TMP(TMPLOC,$JOB,0)=$PIECE(^(0),U,5)_U_$PIECE(^(0),U,6)
- +25 SET UN=""
- SET CNT=0
- FOR
- SET UN=$ORDER(^LRD(65,"AP",LRDFN,UN))
- if UN=""!(CNT'<GMTSNDM)
- QUIT
- DO BASET
- +26 ;K:'CNT ^TMP(TMPLOC,$J)
- +27 QUIT
- BASET ; Sets ^TMP with data elements
- +1 SET (EFLG,DTYP,ULOC)=""
- +2 SET UID=$PIECE(^LRD(65,UN,0),U)
- SET EDT=$PIECE(^(0),U,6)
- SET ABO=$PIECE(^(0),U,7)
- SET RH=$PIECE(^(0),U,8)
- SET VOL=$PIECE(^(0),U,11)
- SET COMP=$PIECE(^LAB(66,$PIECE(^LRD(65,UN,0),U,4),0),U)
- +3 SET ADT=$PIECE(^LRD(65,UN,2,LRDFN,0),U,2)
- +4 ;Gets division unit is located at
- SET UDIV=$PIECE(^LRD(65,UN,0),U,16)
- SET UDIV=$$NS^XUAF4(UDIV)
- SET UDIV=$PIECE(UDIV,"^",1)
- +5 IF $DATA(^LRD(65,UN,8))
- Begin DoDot:1
- +6 SET DIC=65
- SET DIQ="DON"
- SET DIQ(0)="E"
- SET DR=8.3
- SET DA=UN
- DO EN^DIQ1
- +7 if $DATA(DON)
- SET DTYP=DON(65,UN,8.3,"E")
- KILL DA,DIC,DIQ,DON,DR
- QUIT
- End DoDot:1
- +8 SET GMI=$ORDER(^LRD(65,UN,3,0))
- IF +GMI>0
- Begin DoDot:1
- +9 SET ULOC=$PIECE($GET(^LRD(65,UN,3,GMI,0)),U,4)
- End DoDot:1
- +10 ; If unit will expire w/in 48 hrs, flag with "*"; w/in 24 hrs, flag with "**"
- +11 IF EDT>DT
- SET EFLG=$SELECT(EDT-DT<2:"*",EDT-DT<1:"**",1:"")
- +12 SET IDT=9999999-ADT
- +13 IF $SELECT(IDT<GMTS1:1,IDT>GMTS2:1,EDT<DT:1,1:0)
- QUIT
- +14 SET EDT=$TRANSLATE($$FMTE^XLFDT(EDT,"5DZ"),"@"," ")
- +15 FOR
- if '$DATA(^TMP(TMPLOC,$JOB,IDT))
- QUIT
- SET IDT=IDT+.0001
- +16 SET ^TMP(TMPLOC,$JOB,IDT)=EFLG_U_EDT_U_UID_U_COMP_U_VOL_U_ABO_U_RH_U_DTYP_U_UDIV_U_ULOC
- +17 SET CNT=CNT+1
- +18 QUIT
- SET ; Sets CNTR w/appropriate data
- +1 SET TDT=9999999-IDT
- SET ITDT=9999999-$PIECE(TDT,".")
- +2 SET UNITS=+$PIECE(TR,U,7)
- if UNITS'>0
- SET UNITS=1
- +3 SET CNTR(ITDT,+$PIECE(TR,U,2))=+$GET(CNTR(ITDT,+$PIECE(TR,U,2)))+UNITS
- +4 QUIT