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

IBAECM2.m

Go to the documentation of this file.
  1. IBAECM2 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB ; 20-FEB-02
  1. ;;2.0;INTEGRATED BILLING;**176,198,188**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ;
  1. ;Copay calculation for the patient
  1. ;Input:
  1. ;IBMDS - days array
  1. ; IBMDS(0)-first day of the month
  1. ; IBMDS(1)-last day of the month
  1. ; IBMDS(2)-yyymm (like 30201 - for Jan 2002)
  1. ;IBDFN - dfn
  1. ;IBSTART - date to start calclation from,
  1. ; normally it is the first day of the month,
  1. ; but for very first time it will be the effective date
  1. ;IBCLKIEN - 351.81 ien
  1. ;returns 0 if no charges for any reason
  1. ;otherwise returns 1
  1. PROCPAT(IBMDS,IBDFN,IBSTART,IBCLKIEN) ;
  1. ;IBCHRG - charge array, is used for SEND2AR, contains all charges for
  1. ;the patient for this month
  1. ;one day may contain only one rate (charge), that prevents duplications
  1. ; "A",IBDAY,"R"=rate^ien_of_#350.1(i.e.IB action type)
  1. ; "A",IBDAY,"T"=type or care^source^date
  1. ;where
  1. ; outpatient:
  1. ; type or care - 1
  1. ; source - ien of #409.68
  1. ; date - date of service
  1. ; inpatient:
  1. ; type or care - 2
  1. ; source - ien of #405
  1. ; date - date of admission
  1. N IBCHRG
  1. N IBDAY,IBDATE,IBINPAT,IBOUTPAT,IBRET,IBCMCA
  1. N IBINPINF,IBADM1,IBVISIT,IBCOMPEN,IBV1,IBV2
  1. N IBLDINP,IB40968,IBFDAY
  1. S IBCHRG=0,IBLDINP="^"
  1. D CLEAN^IBAECM1(IBDFN)
  1. ; determine first day (IBFDAY) of FOR cycle:
  1. S IBFDAY=1 ;default
  1. S IBSTART=+$G(IBSTART)
  1. ;if effective date is greater than the last day of this month, then do nothing
  1. Q:IBSTART>IBMDS(1) IBCHRG
  1. ;if effective date is in current month, then cycle starts from
  1. ;this day of the month
  1. S IBFDAY=+$E(IBSTART,6,7)
  1. ;if effective date is less than this month, then starts from
  1. ;the first day of the month
  1. S:IBSTART<IBMDS(0) IBFDAY=1
  1. ;----
  1. ; use LOS=1 to get patient status
  1. S IBRET=+$$LTCST^IBAECU(IBDFN,IBMDS(1),1)
  1. ;** EXEMPTION from co-pay **
  1. I IBRET=1 Q IBCHRG ;>>QUIT
  1. ;
  1. ;get all data about all inpatient episodes
  1. ;IBINPAT'=0 - there are inpatient episodes
  1. S IBINPAT=$$INPINFO^IBAECU2(IBMDS(0),IBMDS(1),IBDFN,"IBMJINP",1)
  1. ;get all data about all outpatient episodes
  1. ;IBOUTPAT'=0 - there are outpatient episodes
  1. S IBOUTPAT=$$OUTPINFO^IBAECU3(IBMDS(0),IBMDS(1),IBDFN,"IBMJOUT")
  1. ;no 1010EC - send e-mail and quit
  1. I IBRET=0 D Q IBCHRG ;>>QUIT
  1. . S IBV1=$O(^TMP($J,"IBMJINP",IBDFN,0))
  1. . I +IBV1>0 S IBV1=+$G(^TMP($J,"IBMJINP",IBDFN,IBV1))
  1. . I +IBV1=0 S IBV1=$O(^TMP($J,"IBMJOUT",IBDFN,IBV1))
  1. . I +IBV1=0 S IBV1=IBMDS(0)
  1. . ; changed in 188 to eliminate some messages when nothing there
  1. . I IBINPAT'=0!(IBOUTPAT'=0) D MESS10EC^IBAECU5(IBDFN,IBV1)
  1. . D CLEAN^IBAECM1(IBDFN)
  1. . ; update or clean out current events date
  1. . S DR=".07///"_$S($D(^DPT(IBDFN,.1)):$E(DT,1,5)_"01",1:"@")
  1. . S DIE="^IBA(351.81,",DA=IBCLKIEN D ^DIE
  1. ;
  1. ; if no inpatient, no outpatient episodes and still 21 free days
  1. ; remain - someone cancelled episodes and we cancel the clock
  1. I IBINPAT=0,IBOUTPAT=0,$P($G(^IBA(351.81,IBCLKIEN,0)),"^",6)=21 D Q IBCHRG ;>>QUIT
  1. . D CLCKADJ^IBAECU4("C",IBCLKIEN,IBDFN,"^",IBMDS(1))
  1. . S IBCHRG("A")=0 ; no charges
  1. . D CLEAN^IBAECM1(IBDFN)
  1. ;
  1. ; check correctness of 21 days clock if error then fix it and notify the users
  1. S IBV2=$$CHKDSERR^IBAECU4(IBCLKIEN,IBDFN)
  1. I IBV2<0 D FIX21CLK^IBAECU4(IBCLKIEN)
  1. ; ==============Go thru each day =============================
  1. F IBDAY=IBFDAY:1:IBMDS Q:IBCLKIEN=0 S IBDATE=$$MKDATE^IBAECU4(IBMDS(2),IBDAY) D
  1. . ;***** Gathering all necessary info ******
  1. . ; C&P status
  1. . S IBCOMPEN=$$ISCOMPEN^IBAECU5(IBDFN,IBDATE)
  1. . ; INPATIENT episodes
  1. . S IBADM1=0 ;adm ien
  1. . S IBINPINF="" K IBINPINF("M"),IBINPINF("L")
  1. . ; is any inpatient LTC this day?
  1. . S IBINPINF=$$ISINPAT^IBAECU2(IBDFN,IBDATE,"IBMJINP",.IBINPINF)
  1. . ;
  1. . ; if the patient has inpatient service in the last day of the
  1. . ; processed month, then "CURRENT EVENTS DATE" in LTC clock (#351.81)
  1. . ; must be set to the 1st day of the following month to indicate that
  1. . ; the patient must be checked for LTC copay by MJ next month.
  1. . ; Thus if so we set IBLDINP to IBINPINF (calcualted for the last day
  1. . ; of the processed month)(see CLCKADJ)
  1. . I IBMDS(1)=IBDATE S IBLDINP=IBINPINF
  1. . ; OUTPATIENT episodes
  1. . S IB40968=0
  1. . S IBVISIT="" K IBVISIT("M"),IBVISIT("L")
  1. . ;is there any outp episode with this day?
  1. . S IBVISIT=$$ISOUTP^IBAECU3(IBDFN,IBDATE,"IBMJOUT",.IBVISIT)
  1. . ; If there is LTC event this day (IBDATE) and if current
  1. . ; CLOCK BEGIN DATE > IBDATE then change it to IBDATE
  1. . ; (& reset its expiration date)
  1. . I +IBVISIT!(+IBINPINF) I $P($G(^IBA(351.81,IBCLKIEN,0)),"^",3)>IBDATE D RESET21^IBAECU4(IBCLKIEN,IBDATE,IBDFN)
  1. . ;*****************************************
  1. . ; check 21 days clock file
  1. . ; check expiration date,etc of 21 clock
  1. . S IBCLKIEN=$$CH21BFR^IBAECM1(IBCLKIEN,IBDATE,IBDFN) ;
  1. . I IBCLKIEN=0 Q ;ERROR - new entry in #351.81 was not created - quit !
  1. . ;
  1. . ; 1. LTC inpatient in bed - ALWAYS charge him
  1. . S IBADM1=+$O(IBINPINF("L","SD",0))
  1. . I IBADM1>0 D Q ;>>>>QUIT - GO to NEXT DAY
  1. . . ;look for and cancel Means Test Outpatient charges for this date
  1. . . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
  1. . . ; check expiration date,etc of 21 clock
  1. . . ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
  1. . . ; 1 - if exempted, don't charge the patient
  1. . . I $$EXEMPT21^IBAECU4(IBCLKIEN)=1 D Q
  1. . . . ;add new exempt day to LTC clock
  1. . . . D ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
  1. . . ; otherwise no 21 clock exemption - cretae a charge
  1. . . ;get rate for this treating specialty
  1. . . S IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(2,+$G(IBINPINF("L","SD",IBADM1)),IBDATE)_"^"_$P($G(IBINPINF("L","SD",IBADM1)),"^",2)
  1. . . S IBCHRG("A",IBDAY,"T")="2^"_IBADM1_"^"_$P($G(IBINPINF("L","SD",IBADM1)),"^",3) ;inpatient
  1. . . S IBCHRG=IBCHRG+1
  1. . ;
  1. . ; 2. MeansTest inpatient in bed or in AA,UA or ASIH
  1. . ; do not charge vet for LTC outpatient visit
  1. . ; - MT inpatient care has precedence on LTC outpatient visit if vet is in bed.
  1. . ; - if MT inpatient in AA,UA,ASIH, the current MT rule don't allow to charge him
  1. . ; for MT outpatien visits in AA,UA&ASIH. It was decided to applied the same rules
  1. . ; to LTC outpatient visits
  1. . S IBADM1=+$O(IBINPINF("M",0))
  1. . Q:IBADM1>0 ;............................>>>>QUIT - GO to NEXT DAY
  1. . ;
  1. . ; 3. LTC inpatient in AA,UA or ASIH
  1. . ; do not charge for any (MT or LTC) outpatient visits (see explanation for 2.)
  1. . S IBADM1=+$O(IBINPINF("L","LD",0))
  1. . I IBADM1>0 D Q ;>>>>QUIT - GO to NEXT DAY
  1. . . ;look for and cancel Means Test Outpatient charges for this date
  1. . . ;(at this point can be only outpatient MT charges,
  1. . . ;because inpatient MT has gone earlier in 2.)
  1. . . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
  1. . ;
  1. . ; 4. C&P exam
  1. . ; if C&P exam then any outpatient visits are exempted,no charge,goto NEXT DAY
  1. . Q:IBCOMPEN=1 ;............................>>>>QUIT - GO to NEXT DAY
  1. . ;
  1. . ; 5. LTC outpatient visit
  1. . ;check if vet has a LTC outpatient visit
  1. . S IB40968=+$O(IBVISIT("L",0))
  1. . I IB40968>0 D
  1. . . ;look for and cancel Means Test Outpatient charges for this date
  1. . . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
  1. . . ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
  1. . . ; 1 - if exempted, don't charge the patient
  1. . . I $$EXEMPT21^IBAECU4(IBCLKIEN)=1 D Q
  1. . . . ;add new exempt day to LTC clock
  1. . . . D ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
  1. . . ; otherwise no 21 clock exemption - cretae a charge
  1. . . ;get rate for LTC visit on this date
  1. . . S IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(1,+$G(IBVISIT("L",IB40968)),IBDATE)_"^"_$P($G(IBVISIT("L",IB40968)),"^",2)
  1. . . S IBCHRG("A",IBDAY,"T")="1^"_IB40968_"^"_$$MKDATE^IBAECU4(IBMDS(2),IBDAY) ;outpatient
  1. . . S IBCHRG=IBCHRG+1
  1. . Q
  1. ;=============================================================
  1. I IBCLKIEN=0 Q -1 ;error
  1. ;return month copay
  1. S IBCMCA=$$CLCK180(IBDFN,$S(IBSTART>IBMDS(0):IBSTART,1:IBMDS(0)),IBMDS(1),"IBMJINP")
  1. ; create charges for
  1. ; check expiration date,etc of 21 clock
  1. I IBCHRG>0 D SEND2AR^IBAECU5(IBDFN,.IBCHRG,.IBMDS,+IBCMCA)
  1. ;clock adjustment
  1. D CLCKADJ^IBAECU4("P",IBCLKIEN,IBDFN,IBLDINP,IBMDS(1))
  1. D CLEAN^IBAECM1(IBDFN)
  1. Q IBCHRG
  1. ;
  1. ;returns "max_monthly_calculated_copay"^"is_181+_case"
  1. ;determine 181+ case (takes care about 30 days "gap" between
  1. ;prior 181+ and current admission)
  1. CLCK180(IBDFN,IBBEGDT,IBENDDT,IBLBL) ;
  1. ;array for adm info
  1. N IBLNGADM,IBADMINF,IBRET1,IBCMC,IS180CLK,IBFL5,IB30BACK
  1. S IBADMINF="^"
  1. ; if we have active admission that started before IBMDS(0) then
  1. ; What is the length of this admission?
  1. ; we need IBLNGADM to call $$COPAY^EASECCAL; If there is
  1. ; no admission started before IBMDS(0) then sets IBLNGADM=1
  1. S IBLNGADM=$$DAYS180^IBAECM1(IBBEGDT,IBENDDT,IBDFN,IBLBL,.IBADMINF)
  1. ; if none then check if another admission 30 days before (see SDD)
  1. I IBLNGADM=1 D
  1. . S IBFL5=$$ISLTC^IBAECU5(IBDFN,IBLBL)
  1. . Q:IBFL5=0
  1. . K ^TMP($J,"180DAYS")
  1. . S IB30BACK=$$CHNGDATE^IBAECU4(IBFL5,-30)
  1. . I $$INPINFO^IBAECU2(IB30BACK,IBFL5,IBDFN,"180DAYS",1)=0 Q
  1. . K IBADMINF S IBADMINF="^"
  1. . S IBLNGADM=$$DAYS180^IBAECM1(IB30BACK,IBFL5,IBDFN,"180DAYS",.IBADMINF)
  1. ; get patient status
  1. S IBRET1=$$LTCST^IBAECU(IBDFN,IBENDDT,IBLNGADM)
  1. ;calculate a proper LTC Monthly Copay Amount and put it in IBCMC
  1. ;(max amount patient should pay monthly)
  1. ;IS180CLK =1 if patient has >180 days of continious LTC
  1. S IS180CLK=$$MONTHMAX^IBAECM1(IBDFN,.IBADMINF,IBRET1,IBLNGADM,.IBCMC)
  1. K ^TMP($J,"180DAYS")
  1. Q +IBCMC_"^"_IS180CLK
  1. ;