EASECPC1 ;ALB/LBD,CKN - LTC CoPayment Report continuation ; 12/10/12 5:29pm
;;1.0;ENROLLMENT APPLICATION SYSTEM;**7,24,40,105**;Mar 15, 2001;Build 4
;
; This routine is a continuation of EASECPC.
;
; Input: DFN - Patient file IEN
; DGMTI - LTC Copay Test IEN (file #408.31)
; DGMTDT - LTC Copay Test Date
; MAXRT - Maximum daily copay rates for LTC (OP^IP)
; EASRPT - Report type: 1=Institutional (IP)
; 2=Non-Institutional (OP)
; EASRDT - Report start date
; EASADM - LTC admission date (only if EASRPT=1)
;
START ; Generate Report
N ARRY,IPRPT,DGSP,SRIC,LSEP,DECINF,AGRPAY,ERR
I $G(ZTSK) S ZTREQ="@"
D INIT(EASRDT,.ARRY)
D BLDTBL(.ARRY) Q:$G(ERR)
D PRINT
Q
PRINT ; Print the Report
N CRT,PAGE,RPTDT,LINE,HDR,CALC1,CALC2,SIDX,EIDX,MNTH,NAME,SSN,DOB,LOS
D PRTVAR
U IO
D HEADER
W !,$S(DGSP:"MARRIED",LSEP:"LEGALLY SEPARATED",1:"SINGLE")
W:SRIC ?15,"SPOUSE RESIDING IN THE COMMUNITY"
I DECINF,AGRPAY W !,"*** DECLINED TO PROVIDE INCOME INFORMATION -- AGREED TO PAY COPAYMENTS ***"
I AGRPAY=0 W !,"*** VETERAN IS INELIGIBLE FOR LTC SERVICES -- REFUSED TO SIGN 10-10EC ***"
W !,"LTC COPAY TEST DATE: ",$$FMTE^XLFDT(DGMTDT)
W:$G(EASADM) ?47,"LTC ADMISSION DATE: ",$$FMTE^XLFDT(EASADM)
W !!!,"LTC COPAYMENT CALCULATION"_$S(IPRPT:"S:",1:":")
W ! W:IPRPT "FOR DAYS 1-180 " W CALC1
I IPRPT W !,"FOR DAYS 181+ " W CALC2
;
S SIDX=1,EIDX=6
W !!," "
F MNTH=1:1:6 W $J($P(ARRY(MNTH),"^"),11)
I IPRPT D PRINTROW("TOT ASSETS ",SIDX,EIDX,9)
D PRINTROW("TOT INCOME ",SIDX,EIDX,3)
I 'IPRPT!($G(LOS)<181)!(DGSP&(SRIC)) D PRINTROW("TOT EXPENSES ",SIDX,EIDX,4)
D PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5)
W ! D PRINTROW("CALC COPAY ",SIDX,EIDX,6)
D PRINTROW("MAX COPAY ",SIDX,EIDX,7)
W !,LINE
D PRINTROW("VET COPAY ",SIDX,EIDX,8)
W !,LINE
;
S SIDX=7,EIDX=12
W !!," "
F MNTH=7:1:12 W $J($P(ARRY(MNTH),"^"),11)
I IPRPT D PRINTROW("TOT ASSETS ",SIDX,EIDX,9)
D PRINTROW("TOT INCOME ",SIDX,EIDX,3)
I 'IPRPT!(DGSP&(SRIC)) D PRINTROW("TOT EXPENSES ",SIDX,EIDX,4)
D PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5)
W ! D PRINTROW("CALC COPAY ",SIDX,EIDX,6)
D PRINTROW("MAX COPAY ",SIDX,EIDX,7)
W !,LINE
D PRINTROW("VET COPAY ",SIDX,EIDX,8)
W !,LINE
;
I CRT Q:$$PAUSE(0)
D:CRT HEADER
D NOTETXT
I CRT Q:$$PAUSE(0)
I IPRPT D HEADER,SPNDDWN I CRT Q:$$PAUSE(0)
Q
PRINTROW(TEXT,SIDX,EIDX,NODE) ; Print the Rows
N MNTH
W !,TEXT
F MNTH=SIDX:1:EIDX W $J($S($P(ARRY(MNTH),"^",NODE)[".":$P($P(ARRY(MNTH),"^",NODE),"."),1:$P(ARRY(MNTH),"^",NODE)),11)
Q
PRTVAR ; Set up variables needed to print report
N PAT0
S CRT=$S($E(IOST,1,2)="C-":1,1:0)
S PAGE=0,RPTDT=$$FMTE^XLFDT(DT)
S LINE="",$P(LINE,"-",81)=""
S HDR=$$CJ^XLFSTR("LONG TERM CARE ESTIMATED COPAYMENTS FOR "_$S('IPRPT:"NON-",1:"")_"INSTITUTIONAL SERVICES",80)
S PAT0=$G(^DPT(DFN,0)),NAME=$P(PAT0,"^"),DOB=$P(PAT0,"^",3)
S SSN=$P(PAT0,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
S CALC1="TOTAL INCOME - TOTAL EXPENSES - TOTAL ALLOWANCE"
I DGSP,SRIC S CALC2="(TOTAL ASSETS + TOTAL INCOME) - TOTAL EXPENSES - TOTAL ALLOWANCE"
E S CALC2="(TOTAL ASSETS + TOTAL INCOME) - TOTAL ALLOWANCE"
S:$G(EASADM) LOS=$$FMDIFF^XLFDT(EASRDT,EASADM)
Q
S PAGE=PAGE+1
W @IOF
W RPTDT,?71,"Page: ",$J(PAGE,3)
W !!,HDR
W !!?6,"**This report contains projected estimates based on existing data**"
W !!,NAME,?35,SSN,?62,"DOB: ",$$FMTE^XLFDT(DOB)
Q
PAUSE(RESP) ; Prompt user for next page or quit
N DIR,DIRUT,DUOUT,DTOUT,U,X,Y
S DIR(0)="E"
D ^DIR
I 'Y S RESP=1
Q RESP
;
INIT(DATE,ARRY) ; Initialize the Month/Year Table
N IDX,MNYR
S MNYR=$E(DATE,1,5)_"00"
F IDX=1:1:12 D
.S ARRY(IDX)=$$UP^XLFSTR($$FMTE^XLFDT(MNYR))
.S ARRY(IDX)=$P(ARRY(IDX)," ")_"'"_$E($P(ARRY(IDX)," ",2),3,4)
.S $P(ARRY(IDX),"^",2)=MNYR
.S MNYR=MNYR+100
.S:$E(MNYR,4,5)=13 MNYR=$E(MNYR,1,3)+1_"0100"
Q
BLDTBL(ARRY) ; Get the veteran's financial data, do the copay calculations,
; build the data table
;
N DGDC,DGDEP,DGERR,DGFL,DGIN0,DGIN1,DGIN2,DGINI,DGIRI,DGDET,DGINT,DGNWT
N DGPRI,DGNC,DGND,DGNWTF,DGVINI,DGVIR0,DGVIRI,DGVPRI,DGINTF,CPYFLG,IDX
N OVR180,TAST,TINC,TEXP,ALLOW,CALCCPY,DAYS,MAXCPY,VETMAX,IPDR,OPDR,LOS
;
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,INC^EASECSU3
S IPRPT=$S(EASRPT=1:1,1:0)
S CPYFLG=0
S DECINF=$P($G(^DGMT(408.31,DGMTI,0)),"^",14)
S AGRPAY=$P($G(^DGMT(408.31,DGMTI,0)),"^",11)
I DECINF=1!(AGRPAY=0) S CPYFLG=1
S SRIC=$P(DGVIR0,U,16),LSEP=$P(DGVIR0,U,17)
S OPDR=$P(MAXRT,U),IPDR=$P(MAXRT,U,2)
I IPRPT S LOS=$$FMDIFF^XLFDT(EASRDT,EASADM)+1
;
S OVR180=$S($G(LOS)>180:1,1:0)
S TINC=DGINT/12,TEXP=DGDET/12
I OVR180,('DGSP!('SRIC)) S TEXP=0
S TAST=DGNWT I OVR180 S TAST=$$ASSET
;
; Build data table
F IDX=1:1:12 D
.S DAYS=$$DOM($P(ARRY(IDX),"^",2))
.D CALCALL
.S $P(ARRY(IDX),"^",3)=TINC
.S $P(ARRY(IDX),"^",4)=TEXP
.S $P(ARRY(IDX),"^",5)=ALLOW
.S $P(ARRY(IDX),"^",6)=CALCCPY
.S $P(ARRY(IDX),"^",7)=MAXCPY
.S $P(ARRY(IDX),"^",8)=VETMAX
.S $P(ARRY(IDX),"^",9)=$S(OVR180:TAST,1:"-")
.S:OVR180 TAST=$$ASTSPD
.I $G(LOS) D
..S LOS=LOS+DAYS
..S:'OVR180 OVR180=$S(LOS>180:1,1:0)
..I OVR180,('DGSP!'(SRIC)) S:TEXP TEXP=0
Q
;
CALCALL ; Calculate the allowance and all the copayment amounts
S ALLOW=20*DAYS*(1+SRIC) S:CPYFLG ALLOW=0
S CALCCPY=$$CALCCPY
S MAXCPY=$$CALCMAX(DAYS)
S VETMAX=$$VETMAX(CALCCPY,MAXCPY)
Q
ASSET() ; Initialize asset amount by applying spend-down
N NUM,MNYR,J,DONE,DAYS,ALLOW,CALCCPY,MAXCPY,VETMAX
S DONE=0
; Calculate number of months to spend down the assets
S NUM=(LOS-180)\30
; Get month to start spend down
S MNYR=$$FMADD^XLFDT(EASADM,180)
I NUM>0 F J=1:1:NUM D Q:DONE
.S DAYS=$$DOM(MNYR)
.D CALCALL
.S TAST=$$ASTSPD I TAST=0 S DONE=1 Q
.S MNYR=MNYR+100 S:$E(MNYR,4,5)=13 MNYR=$E(MNYR,1,3)+1_"0100"
Q TAST
ASTSPD() ;Asset Spend down for 180+ days
Q:CPYFLG TAST
I (TINC-TEXP-ALLOW)'>VETMAX D
. I DGSP,SRIC S TAST=TAST-(VETMAX-(TINC-TEXP-ALLOW))
. E S TAST=TAST-(VETMAX-(TINC-ALLOW))
. S:TAST<0 TAST=0
Q TAST
;
CALCCPY() ; Calculate the Co-Pay Amount
;
Q:CPYFLG 0
Q:OVR180 TAST+TINC-ALLOW-TEXP
Q TINC-ALLOW-TEXP
DOM(MNYR) ; Days in Month
; Returns: number of days in a month
N DAYS,MN,YR
S MN=+$E(MNYR,4,5)
I "^4^6^9^11^"[("^"_MN_"^") S DAYS=30 Q DAYS
I MN=2 D Q DAYS
.S DAYS=28
.S YR=$E(MNYR,1,3)+1700
.S:YR#4=0 DAYS=29
S DAYS=31
Q DAYS
CALCMAX(DAYS) ; Calculate the Maximum Co-Pay Amount
;
Q $S(IPRPT:IPDR,1:OPDR)*DAYS
VETMAX(CALCCPY,MAXCPY) ; Calculate the Veteran Maximum Co-Pay Amount
;
Q:CPYFLG MAXCPY
Q:CALCCPY<0 0
Q:CALCCPY<MAXCPY CALCCPY
Q MAXCPY
;
NOTETXT ; Write the Note message
W !!,"IMPORTANT NOTICE: The copayment amounts shown in this report are"
W " estimates",!,"based on calculations of the copayment amount for "
W "an entire month. The",!,"copayment amounts will be adjusted to "
W "reflect the actual start date of LTC",!,"services and the "
W "copayment exemption for the first 21 days of service. The VET",!
W "COPAY amount is based on the assumption that the veteran "
W "will be responsible",!,"to pay the lesser of EITHER the calculated"
W " copayment (CALC COPAY) OR the",!,"maximum copayment (MAX COPAY). "
W "In the event that the calculated copayment",!,"(CALC COPAY) is a "
W "negative figure, the veteran copayment (VET COPAY)",!
W "will be adjusted to zero (0). If the veteran declined to provide"
W " income",!,"information, the veteran will be obligated to pay the"
W " maximum copayment."
Q
;
SPNDDWN ; Text of message to explain the asset spend down
W !!,"EXPLANATION OF ASSET SPEND DOWN CALCULATION:"
W !,"============================================"
W !,"The veteran's assets are included in the calculation of copayments"
W !,"after 180 days of institutional LTC services. The assets then may"
W !,"be reduced each month according to the following formula:"
W !
W !,"Single Veteran:"
W !
W !," TOTAL ASSETS-(VET COPAY-(INCOME-ALLOWANCE))"
W !
W !,"Married Veteran (spouse residing in the community):"
W !
W !," TOTAL ASSETS-(VET COPAY-(INCOME-EXPENSES-ALLOWANCE))"
W !
W !,"In other words, the assets will be reduced by the amount of the"
W !,"veteran's copayment that is not covered by the veteran's income "
W !,"after all expenses and allowances are subtracted. If the amount"
W !,"of the veteran's income after all expenses and allowances are"
W !,"subtracted is greater than the veteran's copayment then the assets"
W !,"will not be reduced."
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASECPC1 8888 printed Apr 09, 2024@20:59:12 Page 2
EASECPC1 ;ALB/LBD,CKN - LTC CoPayment Report continuation ; 12/10/12 5:29pm
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**7,24,40,105**;Mar 15, 2001;Build 4
+2 ;
+3 ; This routine is a continuation of EASECPC.
+4 ;
+5 ; Input: DFN - Patient file IEN
+6 ; DGMTI - LTC Copay Test IEN (file #408.31)
+7 ; DGMTDT - LTC Copay Test Date
+8 ; MAXRT - Maximum daily copay rates for LTC (OP^IP)
+9 ; EASRPT - Report type: 1=Institutional (IP)
+10 ; 2=Non-Institutional (OP)
+11 ; EASRDT - Report start date
+12 ; EASADM - LTC admission date (only if EASRPT=1)
+13 ;
START ; Generate Report
+1 NEW ARRY,IPRPT,DGSP,SRIC,LSEP,DECINF,AGRPAY,ERR
+2 IF $GET(ZTSK)
SET ZTREQ="@"
+3 DO INIT(EASRDT,.ARRY)
+4 DO BLDTBL(.ARRY)
if $GET(ERR)
QUIT
+5 DO PRINT
+6 QUIT
PRINT ; Print the Report
+1 NEW CRT,PAGE,RPTDT,LINE,HDR,CALC1,CALC2,SIDX,EIDX,MNTH,NAME,SSN,DOB,LOS
+2 DO PRTVAR
+3 USE IO
+4 DO HEADER
+5 WRITE !,$SELECT(DGSP:"MARRIED",LSEP:"LEGALLY SEPARATED",1:"SINGLE")
+6 if SRIC
WRITE ?15,"SPOUSE RESIDING IN THE COMMUNITY"
+7 IF DECINF
IF AGRPAY
WRITE !,"*** DECLINED TO PROVIDE INCOME INFORMATION -- AGREED TO PAY COPAYMENTS ***"
+8 IF AGRPAY=0
WRITE !,"*** VETERAN IS INELIGIBLE FOR LTC SERVICES -- REFUSED TO SIGN 10-10EC ***"
+9 WRITE !,"LTC COPAY TEST DATE: ",$$FMTE^XLFDT(DGMTDT)
+10 if $GET(EASADM)
WRITE ?47,"LTC ADMISSION DATE: ",$$FMTE^XLFDT(EASADM)
+11 WRITE !!!,"LTC COPAYMENT CALCULATION"_$SELECT(IPRPT:"S:",1:":")
+12 WRITE !
if IPRPT
WRITE "FOR DAYS 1-180 "
WRITE CALC1
+13 IF IPRPT
WRITE !,"FOR DAYS 181+ "
WRITE CALC2
+14 ;
+15 SET SIDX=1
SET EIDX=6
+16 WRITE !!," "
+17 FOR MNTH=1:1:6
WRITE $JUSTIFY($PIECE(ARRY(MNTH),"^"),11)
+18 IF IPRPT
DO PRINTROW("TOT ASSETS ",SIDX,EIDX,9)
+19 DO PRINTROW("TOT INCOME ",SIDX,EIDX,3)
+20 IF 'IPRPT!($GET(LOS)<181)!(DGSP&(SRIC))
DO PRINTROW("TOT EXPENSES ",SIDX,EIDX,4)
+21 DO PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5)
+22 WRITE !
DO PRINTROW("CALC COPAY ",SIDX,EIDX,6)
+23 DO PRINTROW("MAX COPAY ",SIDX,EIDX,7)
+24 WRITE !,LINE
+25 DO PRINTROW("VET COPAY ",SIDX,EIDX,8)
+26 WRITE !,LINE
+27 ;
+28 SET SIDX=7
SET EIDX=12
+29 WRITE !!," "
+30 FOR MNTH=7:1:12
WRITE $JUSTIFY($PIECE(ARRY(MNTH),"^"),11)
+31 IF IPRPT
DO PRINTROW("TOT ASSETS ",SIDX,EIDX,9)
+32 DO PRINTROW("TOT INCOME ",SIDX,EIDX,3)
+33 IF 'IPRPT!(DGSP&(SRIC))
DO PRINTROW("TOT EXPENSES ",SIDX,EIDX,4)
+34 DO PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5)
+35 WRITE !
DO PRINTROW("CALC COPAY ",SIDX,EIDX,6)
+36 DO PRINTROW("MAX COPAY ",SIDX,EIDX,7)
+37 WRITE !,LINE
+38 DO PRINTROW("VET COPAY ",SIDX,EIDX,8)
+39 WRITE !,LINE
+40 ;
+41 IF CRT
if $$PAUSE(0)
QUIT
+42 if CRT
DO HEADER
+43 DO NOTETXT
+44 IF CRT
if $$PAUSE(0)
QUIT
+45 IF IPRPT
DO HEADER
DO SPNDDWN
IF CRT
if $$PAUSE(0)
QUIT
+46 QUIT
PRINTROW(TEXT,SIDX,EIDX,NODE) ; Print the Rows
+1 NEW MNTH
+2 WRITE !,TEXT
+3 FOR MNTH=SIDX:1:EIDX
WRITE $JUSTIFY($SELECT($PIECE(ARRY(MNTH),"^",NODE)[".":$PIECE($PIECE(ARRY(MNTH),"^",NODE),"."),1:$PIECE(ARRY(MNTH),"^",NODE)),11)
+4 QUIT
PRTVAR ; Set up variables needed to print report
+1 NEW PAT0
+2 SET CRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
+3 SET PAGE=0
SET RPTDT=$$FMTE^XLFDT(DT)
+4 SET LINE=""
SET $PIECE(LINE,"-",81)=""
+5 SET HDR=$$CJ^XLFSTR("LONG TERM CARE ESTIMATED COPAYMENTS FOR "_$SELECT('IPRPT:"NON-",1:"")_"INSTITUTIONAL SERVICES",80)
+6 SET PAT0=$GET(^DPT(DFN,0))
SET NAME=$PIECE(PAT0,"^")
SET DOB=$PIECE(PAT0,"^",3)
+7 SET SSN=$PIECE(PAT0,"^",9)
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)
+8 SET CALC1="TOTAL INCOME - TOTAL EXPENSES - TOTAL ALLOWANCE"
+9 IF DGSP
IF SRIC
SET CALC2="(TOTAL ASSETS + TOTAL INCOME) - TOTAL EXPENSES - TOTAL ALLOWANCE"
+10 IF '$TEST
SET CALC2="(TOTAL ASSETS + TOTAL INCOME) - TOTAL ALLOWANCE"
+11 if $GET(EASADM)
SET LOS=$$FMDIFF^XLFDT(EASRDT,EASADM)
+12 QUIT
+1 SET PAGE=PAGE+1
+2 WRITE @IOF
+3 WRITE RPTDT,?71,"Page: ",$JUSTIFY(PAGE,3)
+4 WRITE !!,HDR
+5 WRITE !!?6,"**This report contains projected estimates based on existing data**"
+6 WRITE !!,NAME,?35,SSN,?62,"DOB: ",$$FMTE^XLFDT(DOB)
+7 QUIT
PAUSE(RESP) ; Prompt user for next page or quit
+1 NEW DIR,DIRUT,DUOUT,DTOUT,U,X,Y
+2 SET DIR(0)="E"
+3 DO ^DIR
+4 IF 'Y
SET RESP=1
+5 QUIT RESP
+6 ;
INIT(DATE,ARRY) ; Initialize the Month/Year Table
+1 NEW IDX,MNYR
+2 SET MNYR=$EXTRACT(DATE,1,5)_"00"
+3 FOR IDX=1:1:12
Begin DoDot:1
+4 SET ARRY(IDX)=$$UP^XLFSTR($$FMTE^XLFDT(MNYR))
+5 SET ARRY(IDX)=$PIECE(ARRY(IDX)," ")_"'"_$EXTRACT($PIECE(ARRY(IDX)," ",2),3,4)
+6 SET $PIECE(ARRY(IDX),"^",2)=MNYR
+7 SET MNYR=MNYR+100
+8 if $EXTRACT(MNYR,4,5)=13
SET MNYR=$EXTRACT(MNYR,1,3)+1_"0100"
End DoDot:1
+9 QUIT
BLDTBL(ARRY) ; Get the veteran's financial data, do the copay calculations,
+1 ; build the data table
+2 ;
+3 NEW DGDC,DGDEP,DGERR,DGFL,DGIN0,DGIN1,DGIN2,DGINI,DGIRI,DGDET,DGINT,DGNWT
+4 NEW DGPRI,DGNC,DGND,DGNWTF,DGVINI,DGVIR0,DGVIRI,DGVPRI,DGINTF,CPYFLG,IDX
+5 NEW OVR180,TAST,TINC,TEXP,ALLOW,CALCCPY,DAYS,MAXCPY,VETMAX,IPDR,OPDR,LOS
+6 ;
+7 SET ERR=0
+8 SET DGPRI=$ORDER(^DGPR(408.12,"C",DFN_";DPT(",0))
IF 'DGPRI
SET ERR=1
QUIT
+9 DO GETIENS^EASECU2(DFN,DGPRI,DGMTDT)
IF '$GET(DGIRI)
IF '$GET(DGINI)
SET ERR=1
QUIT
+10 SET DGVIRI=DGIRI
SET DGVINI=DGINI
+11 DO DEP^EASECSU3
DO INC^EASECSU3
+12 SET IPRPT=$SELECT(EASRPT=1:1,1:0)
+13 SET CPYFLG=0
+14 SET DECINF=$PIECE($GET(^DGMT(408.31,DGMTI,0)),"^",14)
+15 SET AGRPAY=$PIECE($GET(^DGMT(408.31,DGMTI,0)),"^",11)
+16 IF DECINF=1!(AGRPAY=0)
SET CPYFLG=1
+17 SET SRIC=$PIECE(DGVIR0,U,16)
SET LSEP=$PIECE(DGVIR0,U,17)
+18 SET OPDR=$PIECE(MAXRT,U)
SET IPDR=$PIECE(MAXRT,U,2)
+19 IF IPRPT
SET LOS=$$FMDIFF^XLFDT(EASRDT,EASADM)+1
+20 ;
+21 SET OVR180=$SELECT($GET(LOS)>180:1,1:0)
+22 SET TINC=DGINT/12
SET TEXP=DGDET/12
+23 IF OVR180
IF ('DGSP!('SRIC))
SET TEXP=0
+24 SET TAST=DGNWT
IF OVR180
SET TAST=$$ASSET
+25 ;
+26 ; Build data table
+27 FOR IDX=1:1:12
Begin DoDot:1
+28 SET DAYS=$$DOM($PIECE(ARRY(IDX),"^",2))
+29 DO CALCALL
+30 SET $PIECE(ARRY(IDX),"^",3)=TINC
+31 SET $PIECE(ARRY(IDX),"^",4)=TEXP
+32 SET $PIECE(ARRY(IDX),"^",5)=ALLOW
+33 SET $PIECE(ARRY(IDX),"^",6)=CALCCPY
+34 SET $PIECE(ARRY(IDX),"^",7)=MAXCPY
+35 SET $PIECE(ARRY(IDX),"^",8)=VETMAX
+36 SET $PIECE(ARRY(IDX),"^",9)=$SELECT(OVR180:TAST,1:"-")
+37 if OVR180
SET TAST=$$ASTSPD
+38 IF $GET(LOS)
Begin DoDot:2
+39 SET LOS=LOS+DAYS
+40 if 'OVR180
SET OVR180=$SELECT(LOS>180:1,1:0)
+41 IF OVR180
IF ('DGSP!'(SRIC))
if TEXP
SET TEXP=0
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
CALCALL ; Calculate the allowance and all the copayment amounts
+1 SET ALLOW=20*DAYS*(1+SRIC)
if CPYFLG
SET ALLOW=0
+2 SET CALCCPY=$$CALCCPY
+3 SET MAXCPY=$$CALCMAX(DAYS)
+4 SET VETMAX=$$VETMAX(CALCCPY,MAXCPY)
+5 QUIT
ASSET() ; Initialize asset amount by applying spend-down
+1 NEW NUM,MNYR,J,DONE,DAYS,ALLOW,CALCCPY,MAXCPY,VETMAX
+2 SET DONE=0
+3 ; Calculate number of months to spend down the assets
+4 SET NUM=(LOS-180)\30
+5 ; Get month to start spend down
+6 SET MNYR=$$FMADD^XLFDT(EASADM,180)
+7 IF NUM>0
FOR J=1:1:NUM
Begin DoDot:1
+8 SET DAYS=$$DOM(MNYR)
+9 DO CALCALL
+10 SET TAST=$$ASTSPD
IF TAST=0
SET DONE=1
QUIT
+11 SET MNYR=MNYR+100
if $EXTRACT(MNYR,4,5)=13
SET MNYR=$EXTRACT(MNYR,1,3)+1_"0100"
End DoDot:1
if DONE
QUIT
+12 QUIT TAST
ASTSPD() ;Asset Spend down for 180+ days
+1 if CPYFLG
QUIT TAST
+2 IF (TINC-TEXP-ALLOW)'>VETMAX
Begin DoDot:1
+3 IF DGSP
IF SRIC
SET TAST=TAST-(VETMAX-(TINC-TEXP-ALLOW))
+4 IF '$TEST
SET TAST=TAST-(VETMAX-(TINC-ALLOW))
+5 if TAST<0
SET TAST=0
End DoDot:1
+6 QUIT TAST
+7 ;
CALCCPY() ; Calculate the Co-Pay Amount
+1 ;
+2 if CPYFLG
QUIT 0
+3 if OVR180
QUIT TAST+TINC-ALLOW-TEXP
+4 QUIT TINC-ALLOW-TEXP
DOM(MNYR) ; Days in Month
+1 ; Returns: number of days in a month
+2 NEW DAYS,MN,YR
+3 SET MN=+$EXTRACT(MNYR,4,5)
+4 IF "^4^6^9^11^"[("^"_MN_"^")
SET DAYS=30
QUIT DAYS
+5 IF MN=2
Begin DoDot:1
+6 SET DAYS=28
+7 SET YR=$EXTRACT(MNYR,1,3)+1700
+8 if YR#4=0
SET DAYS=29
End DoDot:1
QUIT DAYS
+9 SET DAYS=31
+10 QUIT DAYS
CALCMAX(DAYS) ; Calculate the Maximum Co-Pay Amount
+1 ;
+2 QUIT $SELECT(IPRPT:IPDR,1:OPDR)*DAYS
VETMAX(CALCCPY,MAXCPY) ; Calculate the Veteran Maximum Co-Pay Amount
+1 ;
+2 if CPYFLG
QUIT MAXCPY
+3 if CALCCPY<0
QUIT 0
+4 if CALCCPY<MAXCPY
QUIT CALCCPY
+5 QUIT MAXCPY
+6 ;
NOTETXT ; Write the Note message
+1 WRITE !!,"IMPORTANT NOTICE: The copayment amounts shown in this report are"
+2 WRITE " estimates",!,"based on calculations of the copayment amount for "
+3 WRITE "an entire month. The",!,"copayment amounts will be adjusted to "
+4 WRITE "reflect the actual start date of LTC",!,"services and the "
+5 WRITE "copayment exemption for the first 21 days of service. The VET",!
+6 WRITE "COPAY amount is based on the assumption that the veteran "
+7 WRITE "will be responsible",!,"to pay the lesser of EITHER the calculated"
+8 WRITE " copayment (CALC COPAY) OR the",!,"maximum copayment (MAX COPAY). "
+9 WRITE "In the event that the calculated copayment",!,"(CALC COPAY) is a "
+10 WRITE "negative figure, the veteran copayment (VET COPAY)",!
+11 WRITE "will be adjusted to zero (0). If the veteran declined to provide"
+12 WRITE " income",!,"information, the veteran will be obligated to pay the"
+13 WRITE " maximum copayment."
+14 QUIT
+15 ;
SPNDDWN ; Text of message to explain the asset spend down
+1 WRITE !!,"EXPLANATION OF ASSET SPEND DOWN CALCULATION:"
+2 WRITE !,"============================================"
+3 WRITE !,"The veteran's assets are included in the calculation of copayments"
+4 WRITE !,"after 180 days of institutional LTC services. The assets then may"
+5 WRITE !,"be reduced each month according to the following formula:"
+6 WRITE !
+7 WRITE !,"Single Veteran:"
+8 WRITE !
+9 WRITE !," TOTAL ASSETS-(VET COPAY-(INCOME-ALLOWANCE))"
+10 WRITE !
+11 WRITE !,"Married Veteran (spouse residing in the community):"
+12 WRITE !
+13 WRITE !," TOTAL ASSETS-(VET COPAY-(INCOME-EXPENSES-ALLOWANCE))"
+14 WRITE !
+15 WRITE !,"In other words, the assets will be reduced by the amount of the"
+16 WRITE !,"veteran's copayment that is not covered by the veteran's income "
+17 WRITE !,"after all expenses and allowances are subtracted. If the amount"
+18 WRITE !,"of the veteran's income after all expenses and allowances are"
+19 WRITE !,"subtracted is greater than the veteran's copayment then the assets"
+20 WRITE !,"will not be reduced."
+21 WRITE !
+22 QUIT
