EASECCAL ;ALB/LBD - Calculate LTC copayment ;27 AUG 2001
;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,19,34,39,40**;Mar 15, 2001
;
; Input -- DFN Patient IEN
; MNTH Last day of month for the LTC copay calculation
; in FM format (e.g. 3020131)
; LOS (Length of stay) The number of days in the patient's
; LTC episode
; Output -- COPAY String containing copayment calculation
; = 0: no completed LTC copay test on file
; piece 1: LTC copay test status
; (1=Exempt; 2=Non-Exempt)
; 2: If Exempt, Reason for Exemption
; (IEN to file #714.1)
; 3: Calculated LTC copayment for IP
; (1-180 days)
; 4: Calculated LTC copayment for IP
; (181+ days)
; 5: Calculated LTC copayment for OP
;
COPAY(DFN,MNTH,LOS) ;
N COPAY,DAYS,MX,IPDR,OPDR,IPMAX,OPMAX,LST,DGMT,DGMTI,DGMTDT,DGSTA,DGEXR
N ERR,X1,X2,INC,EXP,AST,ALLOW,DGSP,SRIC
S COPAY=0
I 'DFN!('MNTH) G Q
S LOS=+$G(LOS),DAYS=$E(MNTH,6,7)
; Get maximum daily rate for LTC copayments
; DBIA #3717
S MX=$$MAXRATE^IBAECU(MNTH),OPDR=$P(MX,U),IPDR=$P(MX,U,2) I 'OPDR!('IPDR) G Q
; Calculate maximum copayment for the month
S OPMAX=DAYS*OPDR,IPMAX=DAYS*IPDR
; Get last completed LTC copay test
S LST=$$LST^EASECU(DFN,MNTH,3) I +LST=0 G Q
S DGMTI=$P(LST,U),DGMT(0)=$G(^DGMT(408.31,DGMTI,0)) I 'DGMT(0) G Q
S DGMTDT=+DGMT(0),DGSTA=$P($G(^DG(408.32,+$P(DGMT(0),U,3),0)),U,1)
S DGEXR=$P($G(^DGMT(408.31,DGMTI,2)),U,7)
; If LTC copay test status is neither NON-EXEMPT nor EXEMPT, quit
I DGSTA'="NON-EXEMPT",DGSTA'="EXEMPT" G Q
; If LTC copay test is more than a year old and the veteran does
; not have an exemption for eligibility (Compensable SC) or LTC
; before 11/30/99, quit (Added for LTC Phase III - EAS*1*34)
;S X1=MNTH,X2=DGMTDT D ^%DTC I X>365,"^1^4^"'[(U_DGEXR_U) G Q
S COPAY=$S(DGSTA="EXEMPT":1,1:2)_U
; If test status = 'EXEMPT', get Reason for Exemption
I DGSTA="EXEMPT" S COPAY=COPAY_DGEXR
; If veteran declined to give financial info, copay = max monthly copay
I $P(DGMT(0),U,14) S COPAY=COPAY_U_IPMAX_U_IPMAX_U_OPMAX G Q
; Get total income, assets and expenses for veteran (and spouse)
D FINTOT I $G(ERR) D G Q
.I +COPAY=1 Q
.;no financial data but veteran agreed to pay copayments, copay = max
.I $P(DGMT(0),U,11) S COPAY=COPAY_U_IPMAX_U_IPMAX_U_OPMAX Q
.S COPAY=0
; Calculate copayments
D CALC
Q ; Quit and return COPAY
Q COPAY
;
FINTOT ; Get total income, assets and expenses for veteran (and spouse)
N DGDC,DGDEP,DGDET,DGERR,DGIN0,DGIN1,DGIN2,DGINI,DGINT,DGINTF,DGIRI
N DGNC,DGND,DGNWT,DGNWTF,DGPRI,DGVINI,DGVIR0,DGVIRI
S ERR=0
S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0)) I 'DGPRI S ERR=1 Q
D GETIENS^EASECU2(DFN,DGPRI,DGMTDT) I '$G(DGIRI),'$G(DGINI) S ERR=1 Q
S DGVIRI=DGIRI,DGVINI=DGINI
D DEP^EASECSU3
D INC^EASECSU3
I DGINT=0,DGDET=0,DGNWT=0 S ERR=1 Q
; Does spouse reside in community?
S SRIC=$P(DGVIR0,U,16)
; Divide income and expense totals by 12 to get monthly amounts
S INC=DGINT/12,EXP=DGDET/12,AST=DGNWT
; Calculate total monthly allowance:
; 20*number of days in month*(veteran+spouse(if married and spouse
; resides in the community))
S ALLOW=20*DAYS*(1+SRIC)
Q
;
CALC ; Calculate copayments
N CCPY,OPCPY,IPCPY1,IPCPY2,TINC,TEXP,TAST,OVR180,IPRPT,CPYFLG,EASADM
; Calculation for IP services up to 180 days and OP services:
; Income-Allowance-Expenses
S CCPY=INC-ALLOW-EXP
S (OPCPY,IPCPY1)=$S(CCPY>0:(CCPY+.5)\1,1:0)
; Calculation for IP services 181+ days, add in assets
S IPCPY2=0 I LOS>180 D
. S TEXP=0 I DGSP,SRIC S TEXP=TEXP+EXP
. S TINC=INC,TAST=AST,(OVR180,IPRPT)=1,CPYFLG=0
. S EASADM=$$FMADD^XLFDT(MNTH,-LOS)
. ; Get value of assets after spenddown is applied
. S TAST=$$ASSET^EASECPC1
. S CCPY=CCPY+TAST
. ;If veteran is single or spouse does not reside in the community,
. ;add expenses back in
. I 'DGSP!('SRIC) S CCPY=CCPY+EXP
. S IPCPY2=(CCPY+.5)\1 I IPCPY2<0 S IPCPY2=0
S COPAY=COPAY_U_IPCPY1_U_IPCPY2_U_OPCPY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASECCAL 4310 printed Dec 13, 2024@01:53:49 Page 2
EASECCAL ;ALB/LBD - Calculate LTC copayment ;27 AUG 2001
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,19,34,39,40**;Mar 15, 2001
+2 ;
+3 ; Input -- DFN Patient IEN
+4 ; MNTH Last day of month for the LTC copay calculation
+5 ; in FM format (e.g. 3020131)
+6 ; LOS (Length of stay) The number of days in the patient's
+7 ; LTC episode
+8 ; Output -- COPAY String containing copayment calculation
+9 ; = 0: no completed LTC copay test on file
+10 ; piece 1: LTC copay test status
+11 ; (1=Exempt; 2=Non-Exempt)
+12 ; 2: If Exempt, Reason for Exemption
+13 ; (IEN to file #714.1)
+14 ; 3: Calculated LTC copayment for IP
+15 ; (1-180 days)
+16 ; 4: Calculated LTC copayment for IP
+17 ; (181+ days)
+18 ; 5: Calculated LTC copayment for OP
+19 ;
COPAY(DFN,MNTH,LOS) ;
+1 NEW COPAY,DAYS,MX,IPDR,OPDR,IPMAX,OPMAX,LST,DGMT,DGMTI,DGMTDT,DGSTA,DGEXR
+2 NEW ERR,X1,X2,INC,EXP,AST,ALLOW,DGSP,SRIC
+3 SET COPAY=0
+4 IF 'DFN!('MNTH)
GOTO Q
+5 SET LOS=+$GET(LOS)
SET DAYS=$EXTRACT(MNTH,6,7)
+6 ; Get maximum daily rate for LTC copayments
+7 ; DBIA #3717
+8 SET MX=$$MAXRATE^IBAECU(MNTH)
SET OPDR=$PIECE(MX,U)
SET IPDR=$PIECE(MX,U,2)
IF 'OPDR!('IPDR)
GOTO Q
+9 ; Calculate maximum copayment for the month
+10 SET OPMAX=DAYS*OPDR
SET IPMAX=DAYS*IPDR
+11 ; Get last completed LTC copay test
+12 SET LST=$$LST^EASECU(DFN,MNTH,3)
IF +LST=0
GOTO Q
+13 SET DGMTI=$PIECE(LST,U)
SET DGMT(0)=$GET(^DGMT(408.31,DGMTI,0))
IF 'DGMT(0)
GOTO Q
+14 SET DGMTDT=+DGMT(0)
SET DGSTA=$PIECE($GET(^DG(408.32,+$PIECE(DGMT(0),U,3),0)),U,1)
+15 SET DGEXR=$PIECE($GET(^DGMT(408.31,DGMTI,2)),U,7)
+16 ; If LTC copay test status is neither NON-EXEMPT nor EXEMPT, quit
+17 IF DGSTA'="NON-EXEMPT"
IF DGSTA'="EXEMPT"
GOTO Q
+18 ; If LTC copay test is more than a year old and the veteran does
+19 ; not have an exemption for eligibility (Compensable SC) or LTC
+20 ; before 11/30/99, quit (Added for LTC Phase III - EAS*1*34)
+21 ;S X1=MNTH,X2=DGMTDT D ^%DTC I X>365,"^1^4^"'[(U_DGEXR_U) G Q
+22 SET COPAY=$SELECT(DGSTA="EXEMPT":1,1:2)_U
+23 ; If test status = 'EXEMPT', get Reason for Exemption
+24 IF DGSTA="EXEMPT"
SET COPAY=COPAY_DGEXR
+25 ; If veteran declined to give financial info, copay = max monthly copay
+26 IF $PIECE(DGMT(0),U,14)
SET COPAY=COPAY_U_IPMAX_U_IPMAX_U_OPMAX
GOTO Q
+27 ; Get total income, assets and expenses for veteran (and spouse)
+28 DO FINTOT
IF $GET(ERR)
Begin DoDot:1
+29 IF +COPAY=1
QUIT
+30 ;no financial data but veteran agreed to pay copayments, copay = max
+31 IF $PIECE(DGMT(0),U,11)
SET COPAY=COPAY_U_IPMAX_U_IPMAX_U_OPMAX
QUIT
+32 SET COPAY=0
End DoDot:1
GOTO Q
+33 ; Calculate copayments
+34 DO CALC
Q ; Quit and return COPAY
+1 QUIT COPAY
+2 ;
FINTOT ; Get total income, assets and expenses for veteran (and spouse)
+1 NEW DGDC,DGDEP,DGDET,DGERR,DGIN0,DGIN1,DGIN2,DGINI,DGINT,DGINTF,DGIRI
+2 NEW DGNC,DGND,DGNWT,DGNWTF,DGPRI,DGVINI,DGVIR0,DGVIRI
+3 SET ERR=0
+4 SET DGPRI=$ORDER(^DGPR(408.12,"C",DFN_";DPT(",0))
IF 'DGPRI
SET ERR=1
QUIT
+5 DO GETIENS^EASECU2(DFN,DGPRI,DGMTDT)
IF '$GET(DGIRI)
IF '$GET(DGINI)
SET ERR=1
QUIT
+6 SET DGVIRI=DGIRI
SET DGVINI=DGINI
+7 DO DEP^EASECSU3
+8 DO INC^EASECSU3
+9 IF DGINT=0
IF DGDET=0
IF DGNWT=0
SET ERR=1
QUIT
+10 ; Does spouse reside in community?
+11 SET SRIC=$PIECE(DGVIR0,U,16)
+12 ; Divide income and expense totals by 12 to get monthly amounts
+13 SET INC=DGINT/12
SET EXP=DGDET/12
SET AST=DGNWT
+14 ; Calculate total monthly allowance:
+15 ; 20*number of days in month*(veteran+spouse(if married and spouse
+16 ; resides in the community))
+17 SET ALLOW=20*DAYS*(1+SRIC)
+18 QUIT
+19 ;
CALC ; Calculate copayments
+1 NEW CCPY,OPCPY,IPCPY1,IPCPY2,TINC,TEXP,TAST,OVR180,IPRPT,CPYFLG,EASADM
+2 ; Calculation for IP services up to 180 days and OP services:
+3 ; Income-Allowance-Expenses
+4 SET CCPY=INC-ALLOW-EXP
+5 SET (OPCPY,IPCPY1)=$SELECT(CCPY>0:(CCPY+.5)\1,1:0)
+6 ; Calculation for IP services 181+ days, add in assets
+7 SET IPCPY2=0
IF LOS>180
Begin DoDot:1
+8 SET TEXP=0
IF DGSP
IF SRIC
SET TEXP=TEXP+EXP
+9 SET TINC=INC
SET TAST=AST
SET (OVR180,IPRPT)=1
SET CPYFLG=0
+10 SET EASADM=$$FMADD^XLFDT(MNTH,-LOS)
+11 ; Get value of assets after spenddown is applied
+12 SET TAST=$$ASSET^EASECPC1
+13 SET CCPY=CCPY+TAST
+14 ;If veteran is single or spouse does not reside in the community,
+15 ;add expenses back in
+16 IF 'DGSP!('SRIC)
SET CCPY=CCPY+EXP
+17 SET IPCPY2=(CCPY+.5)\1
IF IPCPY2<0
SET IPCPY2=0
End DoDot:1
+18 SET COPAY=COPAY_U_IPCPY1_U_IPCPY2_U_OPCPY
+19 QUIT
