- 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 Jan 18, 2025@03:07:22 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 ;