Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VBECA4

VBECA4.m

Go to the documentation of this file.
  1. VBECA4 ;HINES OI/REL-APIs for Health Summary ;10/12/00 14:02
  1. ;;2.0;VBEC;**8**;Jun 05, 2015;Build 27
  1. ;
  1. ; Note: This routine supports data exchange with an FDA registered
  1. ; medical device. As such, it may not be changed in any way without
  1. ; prior written approval from the medical device manufacturer.
  1. ;
  1. ; Integration Agreements:
  1. ; Call to $$FMTE^XLFDT is supported by IA: 10103
  1. ; Call to EN^DIQ is supported by IA: 10004
  1. ; Call to $$NS^XUAF4 is supported by IA: 2171
  1. ; Reference to $$LRDFN^LR7OR1 supported by IA #2503
  1. ;
  1. QUIT
  1. ;
  1. ; ----------------------------------------------------------------
  1. ; Private Method Supports IA 3176
  1. ; ----------------------------------------------------------------
  1. TRAN(DFN,TMPLOC,GMTS1,GMTS2) ; Get Transfusion Data for Health Summary
  1. ; Input variables:
  1. ; DFN = Internal number of patient
  1. ; TMPLOC = Node in ^TMP to be used for output data array
  1. ; GMTS1 = Inverse end date of search
  1. ; GMTS2 = Inverse start date of search
  1. ;
  1. ; Output is data array:
  1. ; ^TMP(TMPLOC,$J,n)
  1. N LRDFN,IDT,CNTR,TR,PN,PRODUCT,UNITS,TDT,ITDT,ARR
  1. Q:$G(TMPLOC)=""
  1. K ^TMP(TMPLOC,$J)
  1. Q:'$G(DFN)
  1. S:'$G(GMTS1) GMTS1=5555555 S:'$G(GMTS2) GMTS2=9999999
  1. ;
  1. D TRAN^VBECA1B(DFN)
  1. S IDT=GMTS1-1 F S IDT=$O(ARR(IDT)) Q:+IDT'>0!(IDT>GMTS2) D
  1. . S ^TMP(TMPLOC,$J,IDT)=ARR(IDT)
  1. . S ^TMP(TMPLOC,$J,$P($P(ARR(IDT),"\",2),";"))=ARR($P($P(ARR(IDT),"\",2),";"))
  1. Q
  1. ;
  1. S LRDFN=$$LRDFN^LR7OR1(DFN) Q:'LRDFN
  1. S IDT=GMTS1-1 F S IDT=$O(^LR(LRDFN,1.6,IDT)) Q:+IDT'>0!(IDT>GMTS2) D
  1. . S TR=$G(^LR(LRDFN,1.6,IDT,0)) D SET
  1. S IDT=0 F S IDT=$O(CNTR(IDT)) Q:+IDT'>0 D
  1. . S ^TMP(TMPLOC,$J,IDT)=9999999-IDT_U
  1. . S PN=0 F S PN=$O(CNTR(IDT,PN)) Q:PN'>0 D
  1. . . S PRODUCT=$G(^LAB(66,+PN,0)),^TMP(TMPLOC,$J,$P(PRODUCT,U,2))=$P(PRODUCT,U)
  1. . . S ^TMP(TMPLOC,$J,IDT)=^TMP(TMPLOC,$J,IDT)_CNTR(IDT,PN)_"\"_$P(PRODUCT,U,2)_";"
  1. Q
  1. ; ------------------------------------------------------------------
  1. ; Private Method Supports IA 3177
  1. ; ------------------------------------------------------------------
  1. AVUNIT(DFN,TMPLOC,GMTS1,GMTS2,GMTSNDM) ; Get Available Units for Health Summary
  1. ; Input variables:
  1. ; DFN = Internal number of patient
  1. ; TMPLOC = Node in ^TMP to be used for output data array
  1. ; GMTS1 = Inverse end date of search
  1. ; GMTS2 = Inverse start date of search
  1. ; GMTSNDM = Maximum number to be extracted
  1. ;
  1. ; Output is data array:
  1. ; ^TMP(TMPLOC,$J,n)
  1. N LRDFN,IDT,UN,CNT,ABO,ADT,COMP,DTYP,EDT,EFLG,GMI,RH,UDIV,UID,ULOC,VOL,ARR
  1. Q:$G(TMPLOC)=""
  1. K ^TMP(TMPLOC,$J)
  1. Q:'$G(DFN)
  1. S:'$G(GMTS1) GMTS1=5555555 S:'$G(GMTS2) GMTS2=9999999 S:'$G(GMTSNDM) GMTSNDM=999
  1. ; VBECS Implementation
  1. D AVUNIT^VBECA1B("AVUNIT",DFN)
  1. Q:'$D(^TMP("AVUNIT",$J))
  1. S IDT=GMTS1-1+.0001 F S IDT=$O(^TMP("AVUNIT",$J,IDT)) Q:+IDT'>0!(IDT>GMTS2) D
  1. . S ^TMP(TMPLOC,$J,0)=^TMP("AVUNIT",$J,0)
  1. . S ^TMP(TMPLOC,$J,IDT)=^TMP("AVUNIT",$J,IDT)
  1. Q
  1. ;
  1. S LRDFN=$$LRDFN^LR7OR1(DFN) Q:'LRDFN
  1. I $L($P(^LR(LRDFN,0),U,5,6)) S ^TMP(TMPLOC,$J,0)=$P(^(0),U,5)_U_$P(^(0),U,6)
  1. S UN="",CNT=0 F S UN=$O(^LRD(65,"AP",LRDFN,UN)) Q:UN=""!(CNT'<GMTSNDM) D BASET
  1. ;K:'CNT ^TMP(TMPLOC,$J)
  1. Q
  1. BASET ; Sets ^TMP with data elements
  1. S (EFLG,DTYP,ULOC)=""
  1. 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)
  1. S ADT=$P(^LRD(65,UN,2,LRDFN,0),U,2)
  1. S UDIV=$P(^LRD(65,UN,0),U,16),UDIV=$$NS^XUAF4(UDIV),UDIV=$P(UDIV,"^",1) ;Gets division unit is located at
  1. I $D(^LRD(65,UN,8)) D
  1. . S DIC=65,DIQ="DON",DIQ(0)="E",DR=8.3,DA=UN D EN^DIQ1
  1. . S:$D(DON) DTYP=DON(65,UN,8.3,"E") K DA,DIC,DIQ,DON,DR Q
  1. S GMI=$O(^LRD(65,UN,3,0)) I +GMI>0 D
  1. . S ULOC=$P($G(^LRD(65,UN,3,GMI,0)),U,4)
  1. ; If unit will expire w/in 48 hrs, flag with "*"; w/in 24 hrs, flag with "**"
  1. I EDT>DT S EFLG=$S(EDT-DT<2:"*",EDT-DT<1:"**",1:"")
  1. S IDT=9999999-ADT
  1. I $S(IDT<GMTS1:1,IDT>GMTS2:1,EDT<DT:1,1:0) Q
  1. S EDT=$TR($$FMTE^XLFDT(EDT,"5DZ"),"@"," ")
  1. F Q:'$D(^TMP(TMPLOC,$J,IDT)) S IDT=IDT+.0001
  1. S ^TMP(TMPLOC,$J,IDT)=EFLG_U_EDT_U_UID_U_COMP_U_VOL_U_ABO_U_RH_U_DTYP_U_UDIV_U_ULOC
  1. S CNT=CNT+1
  1. Q
  1. SET ; Sets CNTR w/appropriate data
  1. S TDT=9999999-IDT,ITDT=9999999-$P(TDT,".")
  1. S UNITS=+$P(TR,U,7) S:UNITS'>0 UNITS=1
  1. S CNTR(ITDT,+$P(TR,U,2))=+$G(CNTR(ITDT,+$P(TR,U,2)))+UNITS
  1. Q