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

IBAECU2.m

Go to the documentation of this file.
  1. IBAECU2 ;WOIFO/SS-LTC PHASE 2 UTILITIES ; 20-FEB-02
  1. ;;2.0;INTEGRATED BILLING;**171,176,198**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ;****** Inpatient LTC related utilities *********
  1. ;/*--
  1. ;Returns info about all admissions via ^TMP($J,IBADM,IBDFN) global
  1. ;
  1. ;Input:
  1. ;
  1. ;IBFRBEG- first date (in FM format),must be a valid,
  1. ; (wrong date like 3000231 will cause mistakes)
  1. ;IBFREND- last date (in FM format),must be a valid date
  1. ; if any of dates above > yesterday it will be set to yesterday
  1. ;
  1. ;IBDFN - patient's ien in file (#2)
  1. ;IBADM - any string to identify results in ^TMP($J,IBADM
  1. ;IBDETL - 1 if you need details of each stay day in ^TMP global
  1. ; - 0 if you do not need it
  1. ;Output:
  1. ;
  1. ;temp global array with inpatient info:
  1. ; ^TMP($J,IBADM,IBDFN,IBIEN405)=
  1. ; Pieces :
  1. ; #1 - admission date
  1. ; #2 - discharge date
  1. ; #3 - last_date_of_admission
  1. ; #4 - stay_days in specified date frame $$STAYDS()
  1. ; #5 - days_on_leave in specified date frame $$LEAVDS()
  1. ; #6 - total admission days
  1. ;
  1. ;Daily info for all stay days about LTC/MeansTest belonging,rate
  1. ;and specialty (it may vary during the admission)
  1. ; ^TMP($J,IBADM,IBDFN,IBIEN405,"SD",date)=L/M^rate^specialty
  1. ; where pieces:
  1. ; #1 - "L" for LTC, "M" for MeansTest
  1. ; #2 - 0
  1. ; #3 - specialty ptr to file #42.4
  1. ; #4 - pointer to #350.1 IB action type
  1. ;
  1. ;Daily info about leave days
  1. ; ^TMP($J,IBADM,IBDFN,IBIEN405,"LD") how many days on leave
  1. ; ^TMP($J,IBADM,IBDFN,IBIEN405,"LD",date_on_leave)=""
  1. ;
  1. ;Returns:
  1. ; 0 - none
  1. ; 1 - if any leave or stay days in the period
  1. INPINFO(IBFRBEG,IBFREND,IBDFN,IBADM,IBDETL) ;
  1. N IBRDT,IBDT6,IBDT6A,IBRDTBEG,IBRDTEND,IBIEN1,IBIEN3,IBIEN6,IBNODE01,IBSTRT,IBFL
  1. N IBNODE03,IBTYP,IBSPEC,IBLASTD,IBSTAYDS,IBLEAVDS,IBDISCH,IBADMDS,IBADMDT
  1. N IBYESTRD,IBTEMP
  1. N IBRETVAL S IBRETVAL=0
  1. S IBLEAVDS=0,IBSTAYDS=0
  1. D NOW^%DTC S IBYESTRD=%\1,IBYESTRD=$$CHNGDATE^IBAECU4(IBYESTRD,-1)
  1. S:IBYESTRD<IBFRBEG IBFRBEG=IBYESTRD
  1. S:IBYESTRD<IBFREND IBFREND=IBYESTRD
  1. ; go thru "reverse admissions starting from IBFREND thru all because
  1. ; an active admission can start any time in the past
  1. S IBRDT=9999999.9999999-(IBFREND_".9999999")
  1. F S IBRDT=$O(^DGPM("ATID1",IBDFN,IBRDT)) Q:IBRDT="" D
  1. . S IBIEN1=$O(^DGPM("ATID1",IBDFN,IBRDT,0))
  1. . I IBIEN1=""!('$D(^DGPM(IBIEN1,0))) D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBIEN1),"Admission (INPINFO)","no admission") Q
  1. . S IBNODE01=$G(^DGPM(IBIEN1,0))
  1. . S IBADMDT=+IBNODE01\1
  1. . S IBIEN3=+$P(IBNODE01,"^",17) ;discharge entry
  1. . I IBIEN3>0 S IBDISCH=+$G(^DGPM(IBIEN3,0))\1
  1. . I IBIEN3=0 S IBDISCH=0
  1. . I IBDISCH>0 I IBDISCH<IBFRBEG Q ;was discharged before start date
  1. . S:IBDISCH>0 IBLASTD=$$CHNGDATE^IBAECU4(IBDISCH,-1) ;do not count discharge
  1. . S:IBDISCH=0 IBLASTD=IBFREND
  1. . ; days on leave
  1. . S IBLEAVDS=$$LEAVDS(IBFRBEG,IBFREND,IBIEN1,IBDFN,IBADM)
  1. . ; treat speclty
  1. . S IBFL=0
  1. . S IBDT6=0,IBSTRT=$S(IBLASTD>IBFREND:IBFREND,1:IBLASTD)
  1. . F S IBDT6=$O(^DGPM("ATS",IBDFN,IBIEN1,IBDT6)) Q:IBDT6="" D
  1. . . S IBSPEC=+$O(^DGPM("ATS",IBDFN,IBIEN1,IBDT6,0)) ;pointer to #45.7
  1. . . S IBDT6A=(9999999.9999999-IBDT6)\1
  1. . . I IBDT6A<IBFRBEG Q:IBFL=1 S IBDT6A=IBFRBEG,IBFL=1 ;IBFL=1 - quit next time
  1. . . S IBTEMP=""
  1. . . I IBSPEC>0 D ;S IBSPEC=pointer to#42.4
  1. . . . S IBSPEC=+$P($G(^DIC(45.7,IBSPEC,0)),"^",2) S:IBSPEC>0 IBTEMP=$$TREATSP(IBSPEC),IBTYP=$P(IBTEMP,"^",1)
  1. . . S:IBSPEC=0 IBTYP="U"
  1. . . S:IBTEMP="" IBTYP="U"
  1. . . F Q:IBDT6A>IBSTRT D
  1. . . . I IBDETL=1,'$D(^TMP($J,IBADM,IBDFN,IBIEN1,"LD",IBSTRT)) S ^TMP($J,IBADM,IBDFN,IBIEN1,"SD",IBSTRT)=IBTYP_"^0^"_IBSPEC_"^"_$P(IBTEMP,"^",3)
  1. . . . S:$D(^TMP($J,IBADM,IBDFN,IBIEN1,"LD",IBSTRT)) ^TMP($J,IBADM,IBDFN,IBIEN1,"LD",IBSTRT)=IBTYP_"^0^"_IBSPEC_"^"_$P(IBTEMP,"^",3)
  1. . . . S IBSTRT=$$CHNGDATE^IBAECU4(IBSTRT,-1)
  1. . ; stay days
  1. . S IBSTAYDS=$$STAYDS(IBFRBEG,IBFREND,IBIEN1,IBDISCH)
  1. . S IBADMDS=$$FMDIFF^XLFDT(IBLASTD,IBADMDT,1)+1
  1. . S ^TMP($J,IBADM,IBDFN,IBIEN1)=IBADMDT_"^"_IBDISCH_"^"_IBLASTD_"^"_IBSTAYDS_"^"_IBLEAVDS_"^"_IBADMDS
  1. . I IBRETVAL=0 S:(IBSTAYDS+IBLEAVDS)>0 IBRETVAL=1
  1. Q IBRETVAL
  1. ;
  1. ;Input:
  1. ;How many days of stay in this month
  1. ;IBDTB -begin date of date frame
  1. ;IBDTE -end date of date frame
  1. ;IBP405 - pointer to Admission entry in #405
  1. ;DSDAY - discharge date, if patient is not duscharged then DSDAY=0
  1. STAYDS(IBDTB,IBDTE,IBP405,DSDAY) ;
  1. S IBDTB=$S($$BILDATE^IBAECN1>IBDTB:$$BILDATE^IBAECN1,1:IBDTB)
  1. I IBDTE<DSDAY!(DSDAY=0) Q $$LOS^IBCU64(IBDTB,IBDTE,2,IBP405)
  1. Q $$LOS^IBCU64(IBDTB,IBDTE,1,IBP405)
  1. ;
  1. ;Input:
  1. ;IBDTB -begin date of the given date range
  1. ;IBDTE -end date of the given date frame
  1. ;IBP405 - pointer to entry in #405
  1. ;IBDFN1 - DFN of the patient
  1. ;IBIDN - identifier for ^TMP node
  1. ;Output :
  1. ;returns as a return value: a number of days on leave
  1. ;returns via ^TMP:
  1. ; ^TMP($J,IBIDN,IBDFN1,IBP405,"LD")=total_days_on_leave_for_the_date_range
  1. ; and for each of days on leave:
  1. ; ^TMP($J,IBIDN,IBDFN1,IBP405,"LD",the_date_on_leave)=""
  1. LEAVDS(IBDTB,IBDTE,IBP405,IBDFN1,IBIDN) ;
  1. N DFN,IBII,IBDT1,IBDT2,IBCNT,IBDS,IBVAR
  1. S DFN=IBDFN1,IBCNT=0
  1. I IBIDN'="" S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD")=0
  1. N DT S DT=$$TODAY^IBAECN1()
  1. N IBLDAYS S IBLDAYS=""
  1. S:IBDTE>DT IBDTE=DT
  1. I $$APLD^DGUTL2(IBP405,.IBLDAYS,IBDTB,IBDTE,"B")=-1 Q 0
  1. ;if no days on leave
  1. I +IBLDAYS(0)=0 Q 0
  1. ;if there is no "movement node" in output of $$APLD^DGUTL2 is normal
  1. I +$O(IBLDAYS(0))=0 D Q IBCNT
  1. . S IBDT1=$P(IBLDAYS(0),"^",2)\1 ;begin
  1. . S IBDT2=$P(IBLDAYS(0),"^",3)\1 ;end
  1. . S IBDS=$P(IBLDAYS(0),"^",1) ;days
  1. . I ($$FMDIFF^XLFDT(IBDT2,IBDT1)+1)'=IBDS S IBCNT=0 D
  1. . . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBP405),"Leave days (LEAVDS), only 0-node","Possibly incorrect number of days on leave")
  1. . S IBFL=0
  1. . F IBVAR=1:1:IBDS Q:IBFL D
  1. . . S IBCNT=IBCNT+1
  1. . . I IBIDN'="" D
  1. . . . S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD")=$G(^TMP($J,IBIDN,IBDFN1,IBP405,"LD"))+1
  1. . . . S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD",IBDT1)=""
  1. . . S:IBDT1=IBDT2 IBFL=1
  1. . . S IBDT1=$$CHNGDATE^IBAECU4(IBDT1,+1)
  1. ;if output of $$APLD^DGUTL2 has "movement node"
  1. S IBII=0
  1. F S IBII=$O(IBLDAYS(IBII)) Q:+IBII=0 D
  1. . S IBDT1=$P(IBLDAYS(IBII),"^",1)\1 ;begin
  1. . S IBDT2=$P(IBLDAYS(IBII),"^",2)\1 ;end
  1. . S IBDS=$P(IBLDAYS(IBII),"^",3) ;days
  1. . S IBFL=0
  1. . F IBVAR=1:1:IBDS Q:IBFL D
  1. . . S IBCNT=IBCNT+1
  1. . . I IBIDN'="" D
  1. . . . S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD")=$G(^TMP($J,IBIDN,IBDFN1,IBP405,"LD"))+1
  1. . . . S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD",IBDT1)=""
  1. . . S:IBDT1=IBDT2 IBFL=1
  1. . . S IBDT1=$$CHNGDATE^IBAECU4(IBDT1,+1)
  1. Q IBCNT
  1. ;
  1. ;/*-----
  1. ;
  1. ;Input:
  1. ;SPEC - the ien of #42.4 Specialty
  1. ;Output:
  1. ;If a LTC Specialty Returns "L^ien of #42.4^ien of 350.1"
  1. ;If not LTC Spec Returns "M^ien of #42.4^"
  1. TREATSP(SPEC) ;
  1. N IBRET,IBNAME,IBATYP
  1. S IBRET=$$LTCSPEC^IBAECU(SPEC)
  1. Q:IBRET=0 "M^"_SPEC_"^"
  1. S IBNAME=$P(IBRET,"^",2)
  1. S IBATYP=$O(^IBE(350.1,"B",IBNAME,0))
  1. Q "L^"_SPEC_"^"_IBATYP
  1. ;
  1. ;/**
  1. ;Goes thru all specialty changes and determines specialty
  1. ;- if meets non-LTC then quits loop & returns 0
  1. ;- if LTC then calculates a number of stay days between specialty
  1. ; change and IBLSTDAY,if the number>180 then quits loop & returns 1
  1. ;Input:
  1. ;IBDFN - DFN of patient
  1. ;IBAMD - ptr to #405 for the admission
  1. ;IBLSTDAY - date from which we count 180 clock days toward the past
  1. ;(these 180 days must include only stay days on LTC
  1. ;and should not include any AA,UA and ASIH days)
  1. ;IBDISCH - discharge date
  1. MORE180(IBDFN,IBADM,IBLSTDAY,IBDISCH) ;
  1. N IBRVDT,IBNONLTC,IBDAYS,IB1,IB2,IBCUR,IBQFLG
  1. S (IBNONLTC,IBDAYS,IBQFLG)=0
  1. S IBRVDT=9999999.9999999-(IBLSTDAY_".9999999")
  1. S IB1=IBRVDT
  1. F S IB1=$O(^DGPM("ATS",IBDFN,IBADM,IB1)) Q:+IB1=0!(IBQFLG'=0) D
  1. . S IBCUR=(9999999.9999999-IB1)\1
  1. . S IB2=$O(^DGPM("ATS",IBDFN,IBADM,IB1,0))
  1. . Q:+IB2=0
  1. . S IB2=+$P($G(^DIC(45.7,IB2,0)),"^",2) I IB2<1 S IBQFLG=-1 Q
  1. . I $P($$TREATSP(IB2),"^",1)="M" S IBQFLG=-1 Q
  1. . S IBDAYS=$$STAYDS(IBCUR,IBLSTDAY,IBADM,IBDISCH)
  1. . I IBDAYS>180 S IBQFLG=1 Q
  1. Q IBQFLG=1
  1. ;
  1. ;/**
  1. ;is there any inpatient episode with that day
  1. ;Input:
  1. ;IBDFN - dfn of the patient
  1. ;IBDT1 - date
  1. ;IBTMPLB - ^TMP global subscript like IBADM in $$INPINFO
  1. ;Output:
  1. ;Returns "a^b" where :
  1. ;a - number of LTC admissions on this date
  1. ;b - number of Means Test admissions on this date
  1. ;if "" - nothing
  1. ;means test & stay days:
  1. ;.IBADMS("M","SD",#)=treating specialty^ien of 350.1 IB action type^admission date
  1. ;means test & leave days
  1. ;.IBADMS("M","LD",#)=treating specialty^ien of 350.1 IB action type^admission date
  1. ;LTC & stay days
  1. ;.IBADMS("L","SD",#)=treating specialty^ien of 350.1 IB action type^admission date
  1. ;LTC & leave days
  1. ;.IBADMS("L","LD",#)=treating specialty^ien of 350.1 IB action type^admission date
  1. ISINPAT(IBDFN,IBDT1,IBTMPLB,IBADMS) ;
  1. N IBADM,IB1,IBRETV,IBSDLD,IBD
  1. S IBADM=0,IBRETV=""
  1. F S IBADM=$O(^TMP($J,IBTMPLB,IBDFN,IBADM)) Q:+IBADM=0 D
  1. . S IBSDLD="SD",IBD=$G(^TMP($J,IBTMPLB,IBDFN,IBADM,"SD",IBDT1))
  1. . I IBD="" S IBSDLD="LD",IBD=$G(^TMP($J,IBTMPLB,IBDFN,IBADM,"LD",IBDT1))
  1. . S IB1=$P(IBD,"^",1)
  1. . I IB1="L" D Q
  1. . . S IBADMS("L",IBSDLD,IBADM)=$P(IBD,"^",3,4)_"^"_+$G(^TMP($J,IBTMPLB,IBDFN,IBADM))
  1. . . S $P(IBRETV,"^",1)=$P($G(IBRETV),"^",1)+1
  1. . I IB1="M" D
  1. . . S IBADMS("M",IBSDLD,IBADM)=$P(IBD,"^",3,4)_"^"_+$G(^TMP($J,IBTMPLB,IBDFN,IBADM))
  1. . . S $P(IBRETV,"^",2)=$P($G(IBRETV),"^",2)+1
  1. Q IBRETV
  1. ;