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