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

IBAECM1.m

Go to the documentation of this file.
  1. IBAECM1 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB ; 20-FEB-02
  1. ;;2.0;INTEGRATED BILLING;**176**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ;Input: IBMDS1 - array with month info
  1. ;IBMDS1 (0)-first day of the month
  1. ;IBMDS1 (1)-last day of the month
  1. ;IBMDS1 (2)-yyymm in Fileman format (like 30201 - for Jan 2002)
  1. MJT ;entry for Monthly Calculation Process
  1. ;(array IBMDS1 must be specified outside!)
  1. Q:'$D(IBMDS1)
  1. ;------ variables
  1. N IBCLKAD1 ; variable to return back from PROCPAT info for clock adjustment
  1. N IBDFN
  1. N IBCLKIE1
  1. N IBONCE ;to detect "more than 1 active clock" case for the patient
  1. N IBCLKDAT ;clock data
  1. N IBSTRTD ;EFFECTIVE DATE
  1. S IBSTRTD=$$BILDATE^IBAECN1()
  1. K ^TMP($J,"IBMJERR")
  1. K ^TMP($J,"IBMJINP")
  1. K ^TMP($J,"IBMJOUT")
  1. ;go thru all patients in #351.81
  1. S IBDFN1=0
  1. ;for each patient in file 351.81
  1. F S IBDFN1=$O(^IBA(351.81,"C",IBDFN1)) Q:+IBDFN1=0 D
  1. . S IBCLKIE1=0,IBERR="",IBONCE=0
  1. . F S IBCLKIE1=+$O(^IBA(351.81,"C",IBDFN1,IBCLKIE1)) Q:+IBCLKIE1=0 D
  1. . . S IBCLKDAT=^IBA(351.81,IBCLKIE1,0)
  1. . . ; quit if STATUS'=OPEN
  1. . . Q:$P(IBCLKDAT,"^",5)'=1
  1. . . ; quit if CURRENT EVENTS DATE="" i.e. no LTC events happend
  1. . . ; this month for the patient
  1. . . Q:$P(IBCLKDAT,"^",7)=""
  1. . . ; quit if CURRENT EVENTS DATE>last day of previous month
  1. . . ; i.e. this patient has been already processed. Probably when MJ already has been run and then crushed.
  1. . . ;in such cases NJ runs MJ again next day. SO we don't need to charge the patient again.
  1. . . Q:$P(IBCLKDAT,"^",7)>IBMDS1(1)
  1. . . ; if error save it in ^TMP for further e-mail
  1. . . I IBONCE>0 D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBCLKIE1),"Clocks","Patient has more than one OPEN LTC clocks") Q
  1. . . S IBONCE=1
  1. . . S IBCLKAD1=""
  1. . . ;process the patient
  1. . . I $$PROCPAT^IBAECM2(.IBMDS1,IBDFN1,IBSTRTD,IBCLKIE1)=-1 D
  1. . . . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBCLKIE1),"Charge","Error with LTC clock creation occured during calculation, no proper charges have been created") Q
  1. ;send all errors to user group
  1. D SENDERR^IBAECU5 ;send all errors
  1. ;if we reach this place that means that we processed everybody
  1. ;and we stamp the date into IB SITE PARAMETERS
  1. S $P(^IBE(350.9,1,0),"^",16)=$$TODAY^IBAECN1()
  1. ;if Nightly Job founds that date $P(^IBE(350.9,1,0),"^",16)
  1. ;is less that begining of current month than NJ runs MJ again and MJ will
  1. ;process a rest patients
  1. Q
  1. ;
  1. ;-----
  1. ;180 clock days issue
  1. ;calculates proper LTC Monthly Copay Amount:
  1. ;IBDFN2 -patient's ien in file #2
  1. ;IBINF - admission info
  1. ;IBENROL - enrollment info (returned by $$COPAY^EASECCAL)
  1. ;IBADMLEN - admission lenght
  1. ;returns:
  1. ; 0- if patient does not have >180 days of continious LTC
  1. ; 1- if patient has >180 days of continious LTC (only stay days are counted)
  1. ;IBAMOUNT - returns back proper amount
  1. MONTHMAX(IBDFN2,IBINF,IBENROL,IBADMLEN,IBAMOUNT) ;
  1. N IB180DS
  1. S IBAMOUNT=+$P(IBENROL,"^",3) ;by default is "<=180 days" amount
  1. ;if less or equal 180 days -quit
  1. I IBADMLEN=1 Q 0 ;>>QUIT
  1. ; how many stay days in this admission:
  1. S IB180DS=$$STAYDS^IBAECU2(IBINF(1),IBINF(3),IBINF,IBINF(2))
  1. ;if stay days <= 180 then quit & return
  1. I IB180DS<181 Q 0 ;>>QUIT
  1. ;if stay days > 180 then we have to check if any treating
  1. ;specialty change breaks this 181+ continious period
  1. ; Analyse all this admission period to find out any 180 days clock
  1. ; breaks related to changing specialty.
  1. ;MORE180(IBDFN,IBADM,IBLSTDAY,IBDISCH)
  1. I $$MORE180^IBAECU2(IBDFN2,IBINF,IBINF(3),IBINF(2))=0 Q 0 ;>>QUIT
  1. ; If there is no any non-LTC specialties during 180 days of stay before
  1. ; discharge or last day of the processing month and stay days >180 :
  1. S IBAMOUNT=+$P(IBENROL,"^",4) ;amount for 181+ days
  1. Q 1
  1. ;---
  1. ;finds the length of active LTC admission that started before IBFRST
  1. ;IBFRST - first date of the date frame
  1. ;IBLAST - last date of the date frame
  1. ;IBDFN - ien of the patient in #2
  1. ;IBLBL - ^TMP identifier
  1. ;returns number of days if found such admission
  1. ;returns 1 if not found
  1. ;.IBINF returns:
  1. ;IBINF - #405 ien
  1. ;IBINF(0) total days of admission
  1. ;IBINF(1) first day of admission
  1. ;IBINF(2) discharge date of admission
  1. ;IBINF(3) last_date_of_admission or last date of
  1. ; this period if vet is not discharged yet
  1. DAYS180(IBFRST,IBLAST,IBDFN,IBLBL,IBINF) ;
  1. N IBV1,IBV2,IBFL,IB405
  1. S IBFL=0
  1. S IB405=0
  1. F S IB405=+$O(^TMP($J,IBLBL,IBDFN,IB405)) Q:IB405=0!(IBFL>0) D
  1. . ;quit if admission started this month
  1. . I +$G(^TMP($J,IBLBL,IBDFN,IB405))'<IBFRST Q
  1. . S IBV1=+$O(^TMP($J,IBLBL,IBDFN,IB405,"SD",0))
  1. . ;if found stay day in the first day and this is LTC service then quit
  1. . I IBV1=IBFRST,$P($G(^TMP($J,IBLBL,IBDFN,IB405,"SD",IBV1)),"^",1)="L" S IBFL=IB405 Q
  1. . S IBV1=+$O(^TMP($J,IBLBL,IBDFN,IB405,"LD",0))
  1. . ;if found leave day in the first day and this is LTC service then quit
  1. . I IBV1=IBFRST,$P($G(^TMP($J,IBLBL,IBDFN,IB405,"LD",IBV1)),"^",1)="L" S IBFL=IB405 Q
  1. I IBFL=0 Q 1 ;not found >>QUIT
  1. ;if found
  1. S IBV1=$G(^TMP($J,IBLBL,IBDFN,IBFL))
  1. Q:IBV1="" 1 ;error >>QUIT
  1. S IBINF=IBFL ;ien of #405
  1. S IBINF(0)=+$P(IBV1,"^",6) ;total number of inpatient days
  1. I IBINF(0)>0 D Q IBINF(0) ;found >>QUIT
  1. . ;first day of admission
  1. . S IBINF(1)=+$P(IBV1,"^",1)
  1. . ;discharge date of admission
  1. . S IBINF(2)=+$P(IBV1,"^",2)
  1. . ;last_date_of_admission
  1. . S IBINF(3)=+$P(IBV1,"^",3)
  1. . ;if no discharge then last day is IBLAST
  1. . ;otherwise last day = discharge
  1. . S:IBINF(2)=0 IBINF(3)=IBLAST
  1. Q 1
  1. ;
  1. ;clean all ^TMP related to the patient
  1. CLEAN(IBDFN2) ;
  1. K ^TMP($J,"IBLTCARR",IBDFN2)
  1. K ^TMP($J,"IBMJINP",IBDFN2)
  1. K ^TMP($J,"IBMJOUT",IBDFN2)
  1. ;K ^TMP($J,"IB180",IBDFN1)
  1. Q
  1. ;--
  1. ;Returns the last day (in FM format) of the previous month
  1. PREVMNTH() ;
  1. N X,X1,X2
  1. D NOW^%DTC
  1. S X1=$E(X,1,5)_"01"
  1. S X2=-1
  1. D C^%DTC
  1. Q X
  1. ;
  1. ;
  1. ;runs for each day of the month for the patient
  1. ;checks LTC clock and makes necessary adjustments
  1. ;Input:
  1. ;IBCLIEN Ien of #351.81
  1. ;IBDT Date in FM format
  1. ;IBDFN Patient's ien of #2
  1. ;Output:
  1. ;returns current IEN or new one if #351.81 entry has been created
  1. ;returns 0 if fatal error
  1. CH21BFR(IBCLIEN,IBDT,IBDFN) ;
  1. N IBCLDATA,IB1,IB2,IBLCKER
  1. S IBLCKER=0
  1. S IBCLIEN=+IBCLIEN
  1. S IB1=IBCLIEN
  1. S IBCLDATA=$G(^IBA(351.81,IBCLIEN,0))
  1. I IBCLDATA=""!($P(IBCLDATA,"^",1)="")!($P(IBCLDATA,"^",2)="")!($P(IBCLDATA,"^",3)="") D Q 0
  1. . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","0-node data corrupted in LTC clock")
  1. ; Check clock expiration date
  1. ; if there is no exp date then set it
  1. I $P(IBCLDATA,"^",4)="" D
  1. . S IB2=+$P(IBCLDATA,"^",3)
  1. . S:IB2=0 IB2=IBDT
  1. . L +^IBA(351.81,0):10 I '$T D S IBLCKER=1 Q ;quit
  1. . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: clock was not reset")
  1. . D RESET21^IBAECU4(IBCLIEN,IB2,IBDFN) ;set EXPIRATION DATE
  1. . D FIX21CLK^IBAECU4(IBCLIEN)
  1. . D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
  1. . L -^IBA(351.81,0)
  1. . S IBCLDATA=$G(^IBA(351.81,IBCLIEN,0))
  1. Q:IBLCKER=1 IBCLIEN
  1. ;if clock expired close existent and set new one
  1. I IBDT>$P(IBCLDATA,"^",4) D
  1. . L +^IBA(351.81,0):10 I '$T D Q ;quit
  1. . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: clock was not closed")
  1. . D CLOSECLK^IBAECU4(IBCLIEN,IBDFN)
  1. . D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
  1. . S IBCLIEN=$$NEWCLK^IBAECU4(IBDFN,IBDT)
  1. . I IBCLIEN=0 D L -^IBA(351.81,0) Q
  1. . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: clock was not created")
  1. . D RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN)
  1. . D FIX21CLK^IBAECU4(IBCLIEN)
  1. . D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
  1. . L -^IBA(351.81,0)
  1. Q IBCLIEN
  1. ;add new free day to 21 clock
  1. ;Input:
  1. ;IBCLIEN Ien of #351.81
  1. ;IBDT Date in FM format
  1. ;IBDFN Patient's ien of #2
  1. ADD21DAY(IBCLIEN,IBDT,IBDFN) ;
  1. N IBCLDATA,IB1,IB2
  1. S IBCLIEN=+IBCLIEN
  1. S IB1=IBCLIEN
  1. S IBCLDATA=$G(^IBA(351.81,IBCLIEN,0))
  1. I IBCLDATA="" D Q
  1. . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","0-node data corrupted in LTC clock")
  1. ;if clock is not expired & still DAYS REMAINING>0 - do not charge,
  1. ;add exempt day to clock
  1. I $P(IBCLDATA,"^",4)="" D RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN),FIX21CLK^IBAECU4(IBCLIEN)
  1. I +$P(IBCLDATA,"^",6)=21,+$P(IBCLDATA,"^",3)'=IBDT D RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN) ;if begin date'=1st free day, then fix begin & expir. dates
  1. I $P(IBCLDATA,"^",4)'<IBDT,$P(IBCLDATA,"^",6)>0 D
  1. . L +^IBA(351.81,0):10 I '$T D Q ;quit
  1. . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: new free day not added")
  1. . D ADDEXDAY^IBAECU4(IBCLIEN,IBDT,IBDFN)
  1. . D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
  1. . L -^IBA(351.81,0)
  1. Q
  1. ;
  1. ;entry point ONLY for testing purposes:
  1. ;prepare date range for current month
  1. ;dates,days for processing month
  1. TESTMJ ;
  1. D NOW^%DTC
  1. ;if you want to test MJ for specific month then
  1. ;set X to specific date and run TESTX
  1. TESTX ;
  1. S $P(^IBE(350.9,1,0),"^",16)=0
  1. THEMONTH ;
  1. S IBMDS1(1)=$$LASTDT^IBAECU(X)
  1. S IBMDS1(2)=$E(IBMDS1(1),1,5)
  1. S IBMDS1(0)=IBMDS1(2)_"01",IBMDS1=$E(IBMDS1(1),6,7)
  1. ;run MJ with date range specified outside (above) using MJT entry point
  1. D MJT
  1. ;set LAST LTC COMPLETION DATE to 0 to allow event handlers to update LTC clock file;
  1. S $P(^IBE(350.9,1,0),"^",16)=0
  1. Q
  1. ;