| [613] | 1 | IBAECM2 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB ; 20-FEB-02
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**176,198,188**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;
|
|---|
| 6 | ;Copay calculation for the patient
|
|---|
| 7 | ;Input:
|
|---|
| 8 | ;IBMDS - days array
|
|---|
| 9 | ; IBMDS(0)-first day of the month
|
|---|
| 10 | ; IBMDS(1)-last day of the month
|
|---|
| 11 | ; IBMDS(2)-yyymm (like 30201 - for Jan 2002)
|
|---|
| 12 | ;IBDFN - dfn
|
|---|
| 13 | ;IBSTART - date to start calclation from,
|
|---|
| 14 | ; normally it is the first day of the month,
|
|---|
| 15 | ; but for very first time it will be the effective date
|
|---|
| 16 | ;IBCLKIEN - 351.81 ien
|
|---|
| 17 | ;returns 0 if no charges for any reason
|
|---|
| 18 | ;otherwise returns 1
|
|---|
| 19 | PROCPAT(IBMDS,IBDFN,IBSTART,IBCLKIEN) ;
|
|---|
| 20 | ;IBCHRG - charge array, is used for SEND2AR, contains all charges for
|
|---|
| 21 | ;the patient for this month
|
|---|
| 22 | ;one day may contain only one rate (charge), that prevents duplications
|
|---|
| 23 | ; "A",IBDAY,"R"=rate^ien_of_#350.1(i.e.IB action type)
|
|---|
| 24 | ; "A",IBDAY,"T"=type or care^source^date
|
|---|
| 25 | ;where
|
|---|
| 26 | ; outpatient:
|
|---|
| 27 | ; type or care - 1
|
|---|
| 28 | ; source - ien of #409.68
|
|---|
| 29 | ; date - date of service
|
|---|
| 30 | ; inpatient:
|
|---|
| 31 | ; type or care - 2
|
|---|
| 32 | ; source - ien of #405
|
|---|
| 33 | ; date - date of admission
|
|---|
| 34 | N IBCHRG
|
|---|
| 35 | N IBDAY,IBDATE,IBINPAT,IBOUTPAT,IBRET,IBCMCA
|
|---|
| 36 | N IBINPINF,IBADM1,IBVISIT,IBCOMPEN,IBV1,IBV2
|
|---|
| 37 | N IBLDINP,IB40968,IBFDAY
|
|---|
| 38 | S IBCHRG=0,IBLDINP="^"
|
|---|
| 39 | D CLEAN^IBAECM1(IBDFN)
|
|---|
| 40 | ; determine first day (IBFDAY) of FOR cycle:
|
|---|
| 41 | S IBFDAY=1 ;default
|
|---|
| 42 | S IBSTART=+$G(IBSTART)
|
|---|
| 43 | ;if effective date is greater than the last day of this month, then do nothing
|
|---|
| 44 | Q:IBSTART>IBMDS(1) IBCHRG
|
|---|
| 45 | ;if effective date is in current month, then cycle starts from
|
|---|
| 46 | ;this day of the month
|
|---|
| 47 | S IBFDAY=+$E(IBSTART,6,7)
|
|---|
| 48 | ;if effective date is less than this month, then starts from
|
|---|
| 49 | ;the first day of the month
|
|---|
| 50 | S:IBSTART<IBMDS(0) IBFDAY=1
|
|---|
| 51 | ;----
|
|---|
| 52 | ; use LOS=1 to get patient status
|
|---|
| 53 | S IBRET=+$$LTCST^IBAECU(IBDFN,IBMDS(1),1)
|
|---|
| 54 | ;** EXEMPTION from co-pay **
|
|---|
| 55 | I IBRET=1 Q IBCHRG ;>>QUIT
|
|---|
| 56 | ;
|
|---|
| 57 | ;get all data about all inpatient episodes
|
|---|
| 58 | ;IBINPAT'=0 - there are inpatient episodes
|
|---|
| 59 | S IBINPAT=$$INPINFO^IBAECU2(IBMDS(0),IBMDS(1),IBDFN,"IBMJINP",1)
|
|---|
| 60 | ;get all data about all outpatient episodes
|
|---|
| 61 | ;IBOUTPAT'=0 - there are outpatient episodes
|
|---|
| 62 | S IBOUTPAT=$$OUTPINFO^IBAECU3(IBMDS(0),IBMDS(1),IBDFN,"IBMJOUT")
|
|---|
| 63 | ;no 1010EC - send e-mail and quit
|
|---|
| 64 | I IBRET=0 D Q IBCHRG ;>>QUIT
|
|---|
| 65 | . S IBV1=$O(^TMP($J,"IBMJINP",IBDFN,0))
|
|---|
| 66 | . I +IBV1>0 S IBV1=+$G(^TMP($J,"IBMJINP",IBDFN,IBV1))
|
|---|
| 67 | . I +IBV1=0 S IBV1=$O(^TMP($J,"IBMJOUT",IBDFN,IBV1))
|
|---|
| 68 | . I +IBV1=0 S IBV1=IBMDS(0)
|
|---|
| 69 | . ; changed in 188 to eliminate some messages when nothing there
|
|---|
| 70 | . I IBINPAT'=0!(IBOUTPAT'=0) D MESS10EC^IBAECU5(IBDFN,IBV1)
|
|---|
| 71 | . D CLEAN^IBAECM1(IBDFN)
|
|---|
| 72 | . ; update or clean out current events date
|
|---|
| 73 | . S DR=".07///"_$S($D(^DPT(IBDFN,.1)):$E(DT,1,5)_"01",1:"@")
|
|---|
| 74 | . S DIE="^IBA(351.81,",DA=IBCLKIEN D ^DIE
|
|---|
| 75 | ;
|
|---|
| 76 | ; if no inpatient, no outpatient episodes and still 21 free days
|
|---|
| 77 | ; remain - someone cancelled episodes and we cancel the clock
|
|---|
| 78 | I IBINPAT=0,IBOUTPAT=0,$P($G(^IBA(351.81,IBCLKIEN,0)),"^",6)=21 D Q IBCHRG ;>>QUIT
|
|---|
| 79 | . D CLCKADJ^IBAECU4("C",IBCLKIEN,IBDFN,"^",IBMDS(1))
|
|---|
| 80 | . S IBCHRG("A")=0 ; no charges
|
|---|
| 81 | . D CLEAN^IBAECM1(IBDFN)
|
|---|
| 82 | ;
|
|---|
| 83 | ; check correctness of 21 days clock if error then fix it and notify the users
|
|---|
| 84 | S IBV2=$$CHKDSERR^IBAECU4(IBCLKIEN,IBDFN)
|
|---|
| 85 | I IBV2<0 D FIX21CLK^IBAECU4(IBCLKIEN)
|
|---|
| 86 | ; ==============Go thru each day =============================
|
|---|
| 87 | F IBDAY=IBFDAY:1:IBMDS Q:IBCLKIEN=0 S IBDATE=$$MKDATE^IBAECU4(IBMDS(2),IBDAY) D
|
|---|
| 88 | . ;***** Gathering all necessary info ******
|
|---|
| 89 | . ; C&P status
|
|---|
| 90 | . S IBCOMPEN=$$ISCOMPEN^IBAECU5(IBDFN,IBDATE)
|
|---|
| 91 | . ; INPATIENT episodes
|
|---|
| 92 | . S IBADM1=0 ;adm ien
|
|---|
| 93 | . S IBINPINF="" K IBINPINF("M"),IBINPINF("L")
|
|---|
| 94 | . ; is any inpatient LTC this day?
|
|---|
| 95 | . S IBINPINF=$$ISINPAT^IBAECU2(IBDFN,IBDATE,"IBMJINP",.IBINPINF)
|
|---|
| 96 | . ;
|
|---|
| 97 | . ; if the patient has inpatient service in the last day of the
|
|---|
| 98 | . ; processed month, then "CURRENT EVENTS DATE" in LTC clock (#351.81)
|
|---|
| 99 | . ; must be set to the 1st day of the following month to indicate that
|
|---|
| 100 | . ; the patient must be checked for LTC copay by MJ next month.
|
|---|
| 101 | . ; Thus if so we set IBLDINP to IBINPINF (calcualted for the last day
|
|---|
| 102 | . ; of the processed month)(see CLCKADJ)
|
|---|
| 103 | . I IBMDS(1)=IBDATE S IBLDINP=IBINPINF
|
|---|
| 104 | . ; OUTPATIENT episodes
|
|---|
| 105 | . S IB40968=0
|
|---|
| 106 | . S IBVISIT="" K IBVISIT("M"),IBVISIT("L")
|
|---|
| 107 | . ;is there any outp episode with this day?
|
|---|
| 108 | . S IBVISIT=$$ISOUTP^IBAECU3(IBDFN,IBDATE,"IBMJOUT",.IBVISIT)
|
|---|
| 109 | . ; If there is LTC event this day (IBDATE) and if current
|
|---|
| 110 | . ; CLOCK BEGIN DATE > IBDATE then change it to IBDATE
|
|---|
| 111 | . ; (& reset its expiration date)
|
|---|
| 112 | . I +IBVISIT!(+IBINPINF) I $P($G(^IBA(351.81,IBCLKIEN,0)),"^",3)>IBDATE D RESET21^IBAECU4(IBCLKIEN,IBDATE,IBDFN)
|
|---|
| 113 | . ;*****************************************
|
|---|
| 114 | . ; check 21 days clock file
|
|---|
| 115 | . ; check expiration date,etc of 21 clock
|
|---|
| 116 | . S IBCLKIEN=$$CH21BFR^IBAECM1(IBCLKIEN,IBDATE,IBDFN) ;
|
|---|
| 117 | . I IBCLKIEN=0 Q ;ERROR - new entry in #351.81 was not created - quit !
|
|---|
| 118 | . ;
|
|---|
| 119 | . ; 1. LTC inpatient in bed - ALWAYS charge him
|
|---|
| 120 | . S IBADM1=+$O(IBINPINF("L","SD",0))
|
|---|
| 121 | . I IBADM1>0 D Q ;>>>>QUIT - GO to NEXT DAY
|
|---|
| 122 | . . ;look for and cancel Means Test Outpatient charges for this date
|
|---|
| 123 | . . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
|
|---|
| 124 | . . ; check expiration date,etc of 21 clock
|
|---|
| 125 | . . ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
|
|---|
| 126 | . . ; 1 - if exempted, don't charge the patient
|
|---|
| 127 | . . I $$EXEMPT21^IBAECU4(IBCLKIEN)=1 D Q
|
|---|
| 128 | . . . ;add new exempt day to LTC clock
|
|---|
| 129 | . . . D ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
|
|---|
| 130 | . . ; otherwise no 21 clock exemption - cretae a charge
|
|---|
| 131 | . . ;get rate for this treating specialty
|
|---|
| 132 | . . S IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(2,+$G(IBINPINF("L","SD",IBADM1)),IBDATE)_"^"_$P($G(IBINPINF("L","SD",IBADM1)),"^",2)
|
|---|
| 133 | . . S IBCHRG("A",IBDAY,"T")="2^"_IBADM1_"^"_$P($G(IBINPINF("L","SD",IBADM1)),"^",3) ;inpatient
|
|---|
| 134 | . . S IBCHRG=IBCHRG+1
|
|---|
| 135 | . ;
|
|---|
| 136 | . ; 2. MeansTest inpatient in bed or in AA,UA or ASIH
|
|---|
| 137 | . ; do not charge vet for LTC outpatient visit
|
|---|
| 138 | . ; - MT inpatient care has precedence on LTC outpatient visit if vet is in bed.
|
|---|
| 139 | . ; - if MT inpatient in AA,UA,ASIH, the current MT rule don't allow to charge him
|
|---|
| 140 | . ; for MT outpatien visits in AA,UA&ASIH. It was decided to applied the same rules
|
|---|
| 141 | . ; to LTC outpatient visits
|
|---|
| 142 | . S IBADM1=+$O(IBINPINF("M",0))
|
|---|
| 143 | . Q:IBADM1>0 ;............................>>>>QUIT - GO to NEXT DAY
|
|---|
| 144 | . ;
|
|---|
| 145 | . ; 3. LTC inpatient in AA,UA or ASIH
|
|---|
| 146 | . ; do not charge for any (MT or LTC) outpatient visits (see explanation for 2.)
|
|---|
| 147 | . S IBADM1=+$O(IBINPINF("L","LD",0))
|
|---|
| 148 | . I IBADM1>0 D Q ;>>>>QUIT - GO to NEXT DAY
|
|---|
| 149 | . . ;look for and cancel Means Test Outpatient charges for this date
|
|---|
| 150 | . . ;(at this point can be only outpatient MT charges,
|
|---|
| 151 | . . ;because inpatient MT has gone earlier in 2.)
|
|---|
| 152 | . . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
|
|---|
| 153 | . ;
|
|---|
| 154 | . ; 4. C&P exam
|
|---|
| 155 | . ; if C&P exam then any outpatient visits are exempted,no charge,goto NEXT DAY
|
|---|
| 156 | . Q:IBCOMPEN=1 ;............................>>>>QUIT - GO to NEXT DAY
|
|---|
| 157 | . ;
|
|---|
| 158 | . ; 5. LTC outpatient visit
|
|---|
| 159 | . ;check if vet has a LTC outpatient visit
|
|---|
| 160 | . S IB40968=+$O(IBVISIT("L",0))
|
|---|
| 161 | . I IB40968>0 D
|
|---|
| 162 | . . ;look for and cancel Means Test Outpatient charges for this date
|
|---|
| 163 | . . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
|
|---|
| 164 | . . ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
|
|---|
| 165 | . . ; 1 - if exempted, don't charge the patient
|
|---|
| 166 | . . I $$EXEMPT21^IBAECU4(IBCLKIEN)=1 D Q
|
|---|
| 167 | . . . ;add new exempt day to LTC clock
|
|---|
| 168 | . . . D ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
|
|---|
| 169 | . . ; otherwise no 21 clock exemption - cretae a charge
|
|---|
| 170 | . . ;get rate for LTC visit on this date
|
|---|
| 171 | . . S IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(1,+$G(IBVISIT("L",IB40968)),IBDATE)_"^"_$P($G(IBVISIT("L",IB40968)),"^",2)
|
|---|
| 172 | . . S IBCHRG("A",IBDAY,"T")="1^"_IB40968_"^"_$$MKDATE^IBAECU4(IBMDS(2),IBDAY) ;outpatient
|
|---|
| 173 | . . S IBCHRG=IBCHRG+1
|
|---|
| 174 | . Q
|
|---|
| 175 | ;=============================================================
|
|---|
| 176 | I IBCLKIEN=0 Q -1 ;error
|
|---|
| 177 | ;return month copay
|
|---|
| 178 | S IBCMCA=$$CLCK180(IBDFN,$S(IBSTART>IBMDS(0):IBSTART,1:IBMDS(0)),IBMDS(1),"IBMJINP")
|
|---|
| 179 | ; create charges for
|
|---|
| 180 | ; check expiration date,etc of 21 clock
|
|---|
| 181 | I IBCHRG>0 D SEND2AR^IBAECU5(IBDFN,.IBCHRG,.IBMDS,+IBCMCA)
|
|---|
| 182 | ;clock adjustment
|
|---|
| 183 | D CLCKADJ^IBAECU4("P",IBCLKIEN,IBDFN,IBLDINP,IBMDS(1))
|
|---|
| 184 | D CLEAN^IBAECM1(IBDFN)
|
|---|
| 185 | Q IBCHRG
|
|---|
| 186 | ;
|
|---|
| 187 | ;returns "max_monthly_calculated_copay"^"is_181+_case"
|
|---|
| 188 | ;determine 181+ case (takes care about 30 days "gap" between
|
|---|
| 189 | ;prior 181+ and current admission)
|
|---|
| 190 | CLCK180(IBDFN,IBBEGDT,IBENDDT,IBLBL) ;
|
|---|
| 191 | ;array for adm info
|
|---|
| 192 | N IBLNGADM,IBADMINF,IBRET1,IBCMC,IS180CLK,IBFL5,IB30BACK
|
|---|
| 193 | S IBADMINF="^"
|
|---|
| 194 | ; if we have active admission that started before IBMDS(0) then
|
|---|
| 195 | ; What is the length of this admission?
|
|---|
| 196 | ; we need IBLNGADM to call $$COPAY^EASECCAL; If there is
|
|---|
| 197 | ; no admission started before IBMDS(0) then sets IBLNGADM=1
|
|---|
| 198 | S IBLNGADM=$$DAYS180^IBAECM1(IBBEGDT,IBENDDT,IBDFN,IBLBL,.IBADMINF)
|
|---|
| 199 | ; if none then check if another admission 30 days before (see SDD)
|
|---|
| 200 | I IBLNGADM=1 D
|
|---|
| 201 | . S IBFL5=$$ISLTC^IBAECU5(IBDFN,IBLBL)
|
|---|
| 202 | . Q:IBFL5=0
|
|---|
| 203 | . K ^TMP($J,"180DAYS")
|
|---|
| 204 | . S IB30BACK=$$CHNGDATE^IBAECU4(IBFL5,-30)
|
|---|
| 205 | . I $$INPINFO^IBAECU2(IB30BACK,IBFL5,IBDFN,"180DAYS",1)=0 Q
|
|---|
| 206 | . K IBADMINF S IBADMINF="^"
|
|---|
| 207 | . S IBLNGADM=$$DAYS180^IBAECM1(IB30BACK,IBFL5,IBDFN,"180DAYS",.IBADMINF)
|
|---|
| 208 | ; get patient status
|
|---|
| 209 | S IBRET1=$$LTCST^IBAECU(IBDFN,IBENDDT,IBLNGADM)
|
|---|
| 210 | ;calculate a proper LTC Monthly Copay Amount and put it in IBCMC
|
|---|
| 211 | ;(max amount patient should pay monthly)
|
|---|
| 212 | ;IS180CLK =1 if patient has >180 days of continious LTC
|
|---|
| 213 | S IS180CLK=$$MONTHMAX^IBAECM1(IBDFN,.IBADMINF,IBRET1,IBLNGADM,.IBCMC)
|
|---|
| 214 | K ^TMP($J,"180DAYS")
|
|---|
| 215 | Q +IBCMC_"^"_IS180CLK
|
|---|
| 216 | ;
|
|---|
