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 Dec 13, 2024@02:43:48 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
