EASECSCC ;ALB/LBD,HM - LTC Co-Pay Test Screen Completion ;13 AUG 2001 ; 3/20/03 2:24pm
;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40,174**;Mar 15, 2001;Build 26
;
;NOTE: This routine was modified from DGMTSCC for LTC Co-pay
; Input -- DFN Patient IEN
; DGMTACT Menu Action
; DGMTDT Date of Test
; DGMTYPT Type of Test 3=LTC COPAY
; DGMTPAR Annual Means Test Parameters
; DGMTI Annual Means Test IEN
; DGVINI Veteran Individual Annual Income IEN
; DGVIRI Veteran Income Relation IEN
; DGVPRI Veteran Patient Relation IEN
; Output -- DGERR 1=INCOMPLETE and 0=COMPLETE
;
EN N DGCAT,DGCOMF,DGDC,DGDET,DGIN0,DGIN1,DGIN2,DGINT,DGINTF,DGMTS,DGNC,DGND,DGNWT,DGNWTF,DGREF1,DGSP,DGTYC,DGTHA,DGTHB,DGVIR0,DGCOPS,DGCOST,DGRE,DGSTA,DGAGR
S DGERR=0
S DGCOMF=1 D DEP^EASECSU3,INC^EASECSU3
; If veteran's income is below the threshold then exempt from LTC copay
; LTC III (EAS*1*34) modified to make vet with $0 income exempt
I DGINT'>+$$THRES^IBARXEU1(DGMTDT,1,0) D G Q
.D EXMPT(DFN,DGMTI,12)
.D PRT
; Check if test can be completed
D CHK I DGERR W !?3,*7,"LTC copay test cannot be completed." G Q
; Did vet refuse to give income info
I 'DGINTF,'DGNWTF S DGREF1="" D G Q:$D(DTOUT)!($D(DUOUT))
.D REF
.I $D(DGREF) S DGSTA="NON-EXEMPT"
; Get test status (Exempt or Non-Exempt)
D STA G Q:$D(DTOUT)!($D(DUOUT))
; Does vet agree to pay co-payments
I $G(DGSTA)="NON-EXEMPT" D AGREE G Q:$D(DTOUT)!($D(DUOUT))
UPD S DA=DGMTI,DIE="^DGMT(408.31,",DIE("NO^")="",DR="[EASEC COMPLETE LTC CO-PAY TEST]" D ^DIE K DA,DIE,DR I '$D(DGFIN) S DGERR=1 G Q
W !?3,"...The LTC copay test has been completed with a status of ",DGSTA,"..."
D PRT
;
Q K DGFIN,DGREF,DTOUT,DUOUT,Y
Q
;
COM ;Check if user wants to complete the LTC co-pay test
N DIR
S DIR("A")="Do you wish to complete the LTC copay test"
S DIR("B")="YES",DIR(0)="Y" D ^DIR
Q
;
REF ;Check if patient declines to provide income information
N DIR,Y
S DIR("A")="Does veteran decline to give income information"
I $P($G(^DGMT(408.31,DGMTI,0)),"^",14)]"" S DIR("B")=$$YN^DGMTSCU1($P(^(0),"^",14))
S:'$D(DIR("B")) DIR("B")="NO"
S DIR("?")="Answer 'Y' or 'N'."
S DIR("?",1)="Enter whether the veteran declines to provide current income information."
S DIR(0)="Y" D ^DIR K DIR G REFQ:$D(DTOUT)!($D(DUOUT))
S:Y DGREF=""
REFQ Q
;
CHK ;Check if LTC copay test can be completed
; For LTC III (EAS*1*34) removed check if expenses greater than income
N DGA,DGD,DGDEP,DGREL,DGL,DGM,I
D GETREL^DGMTU11(DFN,"CS",$E(DGMTDT,1,3)_"0000",$S($G(DGMTI):DGMTI,1:""))
S DGM=$P(DGVIR0,"^",14),DGL=$P(DGVIR0,"^",17),DGD=$P(DGVIR0,"^",8)
I DGM="" W !?3,"Marital section must be completed." S DGERR=1
; For LTC IV (EAS*1*40) added check for legally separated
I DGM,'DGL,'$D(DGREL("S")) W !?3,"Married is 'YES'. An active spouse for this LTC copay test does not exist." S DGERR=1
I 'DGM,$D(DGREL("S")) W !?3,"An active spouse exists for this LTC copay test. Married should be 'YES'." S DGERR=1
I DGD']"" W !?3,"Dependent Children section must be completed." S DGERR=1
I DGD,'$D(DGREL("C")) W !?3,"Dependent Children is 'YES'. No active children exist." S DGERR=1
I 'DGD,$D(DGREL("C")) W !?3,"Active children exist. Dependent Children should be 'YES'." S DGERR=1
Q:$G(DGERR)
N CNT,ACT,DGDEP,FLAG,DGINCP
D INIT^EASECDEP S CNT=0 D
.F S CNT=$O(DGDEP(CNT)) Q:'CNT I $P(DGDEP(CNT),U,2)="SPOUSE" D Q:$G(DGERR)
..D GETIENS^EASECU2(DFN,$P(DGDEP(CNT),U,20),DGMTDT)
..S DGINCP=$G(^DGMT(408.22,+DGIRI,"MT")) S:DGINCP FLAG=$G(FLAG)+1
..I $G(FLAG)>1 W !?3,"Patient has more than one spouse for this LTC copay test." S DGERR=1
Q
;
STA ;Ask test status
N DIR,Y,SCRN,DGMOH
S DGMTS=$P($G(^DGMT(408.31,DGMTI,0)),U,3)
S DGRE=$P($G(^DGMT(408.31,DGMTI,2)),U,7)
I DGMTS S DGSTA=$P($G(^DG(408.32,DGMTS,0)),U)
I '$D(DGSTA) S DGSTA="NON-EXEMPT"
I DGSTA="EXEMPT",("12"[DGRE),$G(DGINT)>+$$THRES^IBARXEU1(DGMTDT,1,0) S DGSTA="NON-EXEMPT"
I DGSTA="EXEMPT",$G(DGNSTA)="NON-EXEMPT" S DGSTA="NON-EXEMPT"
I DGSTA="NON-EXEMPT" D I DGMOH="Y" Q ;EAS*1.0*174 I NON-EXEMPT CHECK CHECK FOR MOH DATA AND DISPLAY MESSAGE
.S DGMOH=$P($G(^DPT(DFN,.54)),U,1) I DGMOH="Y" W !!,"Veteran is Awarded Medal of Honor - Add a New LTC Copayment Test to update status" ;EAS*1.0*174 HM
S DIR("A")="LTC Copay Test Status" S DIR("B")=DGSTA
S DIR(0)="P^408.32:EM",DIR("S")="I $P(^(0),U,19)=3"
D ^DIR K DIR Q:'Y!($D(DTOUT))!($D(DUOUT))
S DGMTS=+Y,DGSTA=$P(Y,U,2) Q:DGSTA="NON-EXEMPT"
;If Exempt, ask reason for exemption
S DIR("A")="Reason for Exemption"
I DGRE S DIR("B")=$P($G(^EAS(714.1,DGRE,0)),U)
; Screen the look-up on file #714.1. Exemption reasons 1, 2 and 12
; will be screened out unless this is the call from the Edit option
; (DGEFLG=1) and only reason 1 is screened out. Reason 14 added for screening out EAS*1.0*174 HM
S SCRN="2^12^14^" S:$G(DGEFLG) SCRN="" ;do not display 14 EAS*1.0*174 HM
S DIR("S")="I $P(^(0),U,2),""^1^14"_SCRN_"""'[(U_Y_U)" ;do not display 14 EAS*1.0*174 HM
S DIR(0)="P^714.1:EM" D ^DIR K DIR I 'Y!($D(DTOUT))!($D(DUOUT)) D G STA
.W !!,"A reason for exemption must be entered for an Exempt status.",!
S DGRE=+Y
Q
AGREE ;Ask if vet agrees to pay co-payment
N DIR,Y
S DIR("A")="Does the veteran agree to pay copayments"
I $P($G(^DGMT(408.31,DGMTI,0)),U,11)]"" S DIR("B")=$$YN^DGMTSCU1($P(^(0),U,11))
S:'$D(DIR("B")) DIR("B")="YES"
S DIR("?")="Answer 'Y' or 'N'."
S DIR("?",1)="Enter in this field whether the veteran agrees to pay the"
S DIR("?",2)="LTC copayments. The veteran must also sign the 1010-EC form"
S DIR("?",3)="agreeing to pay the copayments. If the veteran does not agree"
S DIR("?",4)="to pay the copayments, the veteran becomes ineligible to"
S DIR("?",5)="receive extended care services."
S DIR(0)="Y" D ^DIR K DIR Q:$D(DTOUT)!($D(DUOUT))
S DGAGR=Y
Q
PRT ;Print Extended Care Services test (1010EC)
N DIR,Y,X,ZTSK
S DIR("A")="PRINT 10-10EC"
S DIR("B")="YES",DIR(0)="Y" D ^DIR G PRTQ:'Y!($D(DTOUT))!($D(DUOUT))
S ZTSK=$$QUE^EASEC10E(DFN,DGMTI)
PRTQ Q
;
EXMPT(DFN,DGMTI,EX) ; Veteran is exempt from LTC co-payments
; Complete LTC co-pay test in Annual Means Test file (#408.31)
; Input -- DFN Patient IEN
; DGMTI Annual Means Test IEN
; EX Copay exemption code
; 1 = SC compensable disability
; 2 = NSC, single, receiving VA pension (no A&A, HB)
; or
; Income (last year) is below single pension threshold
; 12 = Income (current year) is below single pension threshold
; 14 = Veteran Awarded Medal of Honor - EAS*1.0*174 HM
Q:'DGMTI Q:'EX
N DATA,I
W !! F I=1:1:80 W "="
W !!,?10,"Veteran is EXEMPT from Long Term Care copayments."
W !,?10,"Reason for Exemption: ",$P($G(^EAS(714.1,EX,0)),U)
W !! F I=1:1:80 W "="
W !!
S DATA(.03)=$O(^DG(408.32,"C","X","")),DATA(2.07)=EX,DATA(.06)=DUZ
S (DATA(.07),DATA(2.02))=$$NOW^XLFDT
S DATA(.04)=$G(DGINT),DATA(.05)=$G(DGNWT),DATA(.15)=$G(DGDET)
S DATA(.18)=$G(DGND),DATA(2.08)=$P($$GETLTC4^EASECMT(DFN),U,1)
S DATA(.14)=$S($D(DGREF):1,1:0) ;LTC III (EAS*1*34)
I $$UPD^DGENDBS(408.31,DGMTI,.DATA) Q
W !,"ERROR: COULD NOT UPDATE LTC COPAY TEST",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASECSCC 7431 printed Oct 16, 2024@17:55:02 Page 2
EASECSCC ;ALB/LBD,HM - LTC Co-Pay Test Screen Completion ;13 AUG 2001 ; 3/20/03 2:24pm
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40,174**;Mar 15, 2001;Build 26
+2 ;
+3 ;NOTE: This routine was modified from DGMTSCC for LTC Co-pay
+4 ; Input -- DFN Patient IEN
+5 ; DGMTACT Menu Action
+6 ; DGMTDT Date of Test
+7 ; DGMTYPT Type of Test 3=LTC COPAY
+8 ; DGMTPAR Annual Means Test Parameters
+9 ; DGMTI Annual Means Test IEN
+10 ; DGVINI Veteran Individual Annual Income IEN
+11 ; DGVIRI Veteran Income Relation IEN
+12 ; DGVPRI Veteran Patient Relation IEN
+13 ; Output -- DGERR 1=INCOMPLETE and 0=COMPLETE
+14 ;
EN NEW DGCAT,DGCOMF,DGDC,DGDET,DGIN0,DGIN1,DGIN2,DGINT,DGINTF,DGMTS,DGNC,DGND,DGNWT,DGNWTF,DGREF1,DGSP,DGTYC,DGTHA,DGTHB,DGVIR0,DGCOPS,DGCOST,DGRE,DGSTA,DGAGR
+1 SET DGERR=0
+2 SET DGCOMF=1
DO DEP^EASECSU3
DO INC^EASECSU3
+3 ; If veteran's income is below the threshold then exempt from LTC copay
+4 ; LTC III (EAS*1*34) modified to make vet with $0 income exempt
+5 IF DGINT'>+$$THRES^IBARXEU1(DGMTDT,1,0)
Begin DoDot:1
+6 DO EXMPT(DFN,DGMTI,12)
+7 DO PRT
End DoDot:1
GOTO Q
+8 ; Check if test can be completed
+9 DO CHK
IF DGERR
WRITE !?3,*7,"LTC copay test cannot be completed."
GOTO Q
+10 ; Did vet refuse to give income info
+11 IF 'DGINTF
IF 'DGNWTF
SET DGREF1=""
Begin DoDot:1
+12 DO REF
+13 IF $DATA(DGREF)
SET DGSTA="NON-EXEMPT"
End DoDot:1
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO Q
+14 ; Get test status (Exempt or Non-Exempt)
+15 DO STA
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO Q
+16 ; Does vet agree to pay co-payments
+17 IF $GET(DGSTA)="NON-EXEMPT"
DO AGREE
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO Q
UPD SET DA=DGMTI
SET DIE="^DGMT(408.31,"
SET DIE("NO^")=""
SET DR="[EASEC COMPLETE LTC CO-PAY TEST]"
DO ^DIE
KILL DA,DIE,DR
IF '$DATA(DGFIN)
SET DGERR=1
GOTO Q
+1 WRITE !?3,"...The LTC copay test has been completed with a status of ",DGSTA,"..."
+2 DO PRT
+3 ;
Q KILL DGFIN,DGREF,DTOUT,DUOUT,Y
+1 QUIT
+2 ;
COM ;Check if user wants to complete the LTC co-pay test
+1 NEW DIR
+2 SET DIR("A")="Do you wish to complete the LTC copay test"
+3 SET DIR("B")="YES"
SET DIR(0)="Y"
DO ^DIR
+4 QUIT
+5 ;
REF ;Check if patient declines to provide income information
+1 NEW DIR,Y
+2 SET DIR("A")="Does veteran decline to give income information"
+3 IF $PIECE($GET(^DGMT(408.31,DGMTI,0)),"^",14)]""
SET DIR("B")=$$YN^DGMTSCU1($PIECE(^(0),"^",14))
+4 if '$DATA(DIR("B"))
SET DIR("B")="NO"
+5 SET DIR("?")="Answer 'Y' or 'N'."
+6 SET DIR("?",1)="Enter whether the veteran declines to provide current income information."
+7 SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO REFQ
+8 if Y
SET DGREF=""
REFQ QUIT
+1 ;
CHK ;Check if LTC copay test can be completed
+1 ; For LTC III (EAS*1*34) removed check if expenses greater than income
+2 NEW DGA,DGD,DGDEP,DGREL,DGL,DGM,I
+3 DO GETREL^DGMTU11(DFN,"CS",$EXTRACT(DGMTDT,1,3)_"0000",$SELECT($GET(DGMTI):DGMTI,1:""))
+4 SET DGM=$PIECE(DGVIR0,"^",14)
SET DGL=$PIECE(DGVIR0,"^",17)
SET DGD=$PIECE(DGVIR0,"^",8)
+5 IF DGM=""
WRITE !?3,"Marital section must be completed."
SET DGERR=1
+6 ; For LTC IV (EAS*1*40) added check for legally separated
+7 IF DGM
IF 'DGL
IF '$DATA(DGREL("S"))
WRITE !?3,"Married is 'YES'. An active spouse for this LTC copay test does not exist."
SET DGERR=1
+8 IF 'DGM
IF $DATA(DGREL("S"))
WRITE !?3,"An active spouse exists for this LTC copay test. Married should be 'YES'."
SET DGERR=1
+9 IF DGD']""
WRITE !?3,"Dependent Children section must be completed."
SET DGERR=1
+10 IF DGD
IF '$DATA(DGREL("C"))
WRITE !?3,"Dependent Children is 'YES'. No active children exist."
SET DGERR=1
+11 IF 'DGD
IF $DATA(DGREL("C"))
WRITE !?3,"Active children exist. Dependent Children should be 'YES'."
SET DGERR=1
+12 if $GET(DGERR)
QUIT
+13 NEW CNT,ACT,DGDEP,FLAG,DGINCP
+14 DO INIT^EASECDEP
SET CNT=0
Begin DoDot:1
+15 FOR
SET CNT=$ORDER(DGDEP(CNT))
if 'CNT
QUIT
IF $PIECE(DGDEP(CNT),U,2)="SPOUSE"
Begin DoDot:2
+16 DO GETIENS^EASECU2(DFN,$PIECE(DGDEP(CNT),U,20),DGMTDT)
+17 SET DGINCP=$GET(^DGMT(408.22,+DGIRI,"MT"))
if DGINCP
SET FLAG=$GET(FLAG)+1
+18 IF $GET(FLAG)>1
WRITE !?3,"Patient has more than one spouse for this LTC copay test."
SET DGERR=1
End DoDot:2
if $GET(DGERR)
QUIT
End DoDot:1
+19 QUIT
+20 ;
STA ;Ask test status
+1 NEW DIR,Y,SCRN,DGMOH
+2 SET DGMTS=$PIECE($GET(^DGMT(408.31,DGMTI,0)),U,3)
+3 SET DGRE=$PIECE($GET(^DGMT(408.31,DGMTI,2)),U,7)
+4 IF DGMTS
SET DGSTA=$PIECE($GET(^DG(408.32,DGMTS,0)),U)
+5 IF '$DATA(DGSTA)
SET DGSTA="NON-EXEMPT"
+6 IF DGSTA="EXEMPT"
IF ("12"[DGRE)
IF $GET(DGINT)>+$$THRES^IBARXEU1(DGMTDT,1,0)
SET DGSTA="NON-EXEMPT"
+7 IF DGSTA="EXEMPT"
IF $GET(DGNSTA)="NON-EXEMPT"
SET DGSTA="NON-EXEMPT"
+8 ;EAS*1.0*174 I NON-EXEMPT CHECK CHECK FOR MOH DATA AND DISPLAY MESSAGE
IF DGSTA="NON-EXEMPT"
Begin DoDot:1
+9 ;EAS*1.0*174 HM
SET DGMOH=$PIECE($GET(^DPT(DFN,.54)),U,1)
IF DGMOH="Y"
WRITE !!,"Veteran is Awarded Medal of Honor - Add a New LTC Copayment Test to update status"
End DoDot:1
IF DGMOH="Y"
QUIT
+10 SET DIR("A")="LTC Copay Test Status"
SET DIR("B")=DGSTA
+11 SET DIR(0)="P^408.32:EM"
SET DIR("S")="I $P(^(0),U,19)=3"
+12 DO ^DIR
KILL DIR
if 'Y!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+13 SET DGMTS=+Y
SET DGSTA=$PIECE(Y,U,2)
if DGSTA="NON-EXEMPT"
QUIT
+14 ;If Exempt, ask reason for exemption
+15 SET DIR("A")="Reason for Exemption"
+16 IF DGRE
SET DIR("B")=$PIECE($GET(^EAS(714.1,DGRE,0)),U)
+17 ; Screen the look-up on file #714.1. Exemption reasons 1, 2 and 12
+18 ; will be screened out unless this is the call from the Edit option
+19 ; (DGEFLG=1) and only reason 1 is screened out. Reason 14 added for screening out EAS*1.0*174 HM
+20 ;do not display 14 EAS*1.0*174 HM
SET SCRN="2^12^14^"
if $GET(DGEFLG)
SET SCRN=""
+21 ;do not display 14 EAS*1.0*174 HM
SET DIR("S")="I $P(^(0),U,2),""^1^14"_SCRN_"""'[(U_Y_U)"
+22 SET DIR(0)="P^714.1:EM"
DO ^DIR
KILL DIR
IF 'Y!($DATA(DTOUT))!($DATA(DUOUT))
Begin DoDot:1
+23 WRITE !!,"A reason for exemption must be entered for an Exempt status.",!
End DoDot:1
GOTO STA
+24 SET DGRE=+Y
+25 QUIT
AGREE ;Ask if vet agrees to pay co-payment
+1 NEW DIR,Y
+2 SET DIR("A")="Does the veteran agree to pay copayments"
+3 IF $PIECE($GET(^DGMT(408.31,DGMTI,0)),U,11)]""
SET DIR("B")=$$YN^DGMTSCU1($PIECE(^(0),U,11))
+4 if '$DATA(DIR("B"))
SET DIR("B")="YES"
+5 SET DIR("?")="Answer 'Y' or 'N'."
+6 SET DIR("?",1)="Enter in this field whether the veteran agrees to pay the"
+7 SET DIR("?",2)="LTC copayments. The veteran must also sign the 1010-EC form"
+8 SET DIR("?",3)="agreeing to pay the copayments. If the veteran does not agree"
+9 SET DIR("?",4)="to pay the copayments, the veteran becomes ineligible to"
+10 SET DIR("?",5)="receive extended care services."
+11 SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+12 SET DGAGR=Y
+13 QUIT
PRT ;Print Extended Care Services test (1010EC)
+1 NEW DIR,Y,X,ZTSK
+2 SET DIR("A")="PRINT 10-10EC"
+3 SET DIR("B")="YES"
SET DIR(0)="Y"
DO ^DIR
if 'Y!($DATA(DTOUT))!($DATA(DUOUT))
GOTO PRTQ
+4 SET ZTSK=$$QUE^EASEC10E(DFN,DGMTI)
PRTQ QUIT
+1 ;
EXMPT(DFN,DGMTI,EX) ; Veteran is exempt from LTC co-payments
+1 ; Complete LTC co-pay test in Annual Means Test file (#408.31)
+2 ; Input -- DFN Patient IEN
+3 ; DGMTI Annual Means Test IEN
+4 ; EX Copay exemption code
+5 ; 1 = SC compensable disability
+6 ; 2 = NSC, single, receiving VA pension (no A&A, HB)
+7 ; or
+8 ; Income (last year) is below single pension threshold
+9 ; 12 = Income (current year) is below single pension threshold
+10 ; 14 = Veteran Awarded Medal of Honor - EAS*1.0*174 HM
+11 if 'DGMTI
QUIT
if 'EX
QUIT
+12 NEW DATA,I
+13 WRITE !!
FOR I=1:1:80
WRITE "="
+14 WRITE !!,?10,"Veteran is EXEMPT from Long Term Care copayments."
+15 WRITE !,?10,"Reason for Exemption: ",$PIECE($GET(^EAS(714.1,EX,0)),U)
+16 WRITE !!
FOR I=1:1:80
WRITE "="
+17 WRITE !!
+18 SET DATA(.03)=$ORDER(^DG(408.32,"C","X",""))
SET DATA(2.07)=EX
SET DATA(.06)=DUZ
+19 SET (DATA(.07),DATA(2.02))=$$NOW^XLFDT
+20 SET DATA(.04)=$GET(DGINT)
SET DATA(.05)=$GET(DGNWT)
SET DATA(.15)=$GET(DGDET)
+21 SET DATA(.18)=$GET(DGND)
SET DATA(2.08)=$PIECE($$GETLTC4^EASECMT(DFN),U,1)
+22 ;LTC III (EAS*1*34)
SET DATA(.14)=$SELECT($DATA(DGREF):1,1:0)
+23 IF $$UPD^DGENDBS(408.31,DGMTI,.DATA)
QUIT
+24 WRITE !,"ERROR: COULD NOT UPDATE LTC COPAY TEST",!!
+25 QUIT
