EASECA ;ALB/PHH,LBD,HM - Add a New LTC Co-Pay Test ;10 AUG 2001
;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40,174**;Mar 15, 2001;Build 26
;
EN ;Entry point to add a new LTC Co-Pay test
N DGMDOD S DGMDOD=""
S DGMTYPT=3
I $D(DGMTDFN)#2 K DGMTDFN
S DIC="^DPT(",DIC(0)="AEMQ" W !! D ^DIC K DIC G Q:Y<0 S (DFN,DGMTDFN)=+Y
I $P($G(^DPT(DFN,.35)),U)'="" S DGMDOD=$P(^DPT(DFN,.35),U)
I $G(DGMDOD) W !!,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D") Q
; Is patient a veteran? Added for LTC III (EAS*1*34)
I $P($G(^DPT(DFN,"VET")),U)'="Y" W !!,"Patient is not a Veteran." Q
;
S DGLDT=$$LST^EASECU(DFN,"",DGMTYPT),DGLD=$P(DGLDT,U,2),DGLDYR=$E(DGLD,1,3)_"1231"
;
DT S %DT("A")="Date of LTC Copay Test: ",%DT="AEX",%DT(0)="-NOW",%DT("B")="NOW" W ! D ^%DT K %DT G Q:Y<0 S DGMTDT=Y
I DGLD,DGMTDT'>DGLD W !?3,*7,"The date of test must be after the date of the last test on " S Y=DGLD X ^DD("DD") W Y,"." G DT
; LTC III (EAS*1*34) - change to allow multiple tests within a year
I DGLD S X1=DGMTDT,X2=DGLD D ^%DTC I X<365 D G EN:$G(Y)'=1
.W !?3,*7,"An LTC Copay Test already exists on " S Y=DGLD X ^DD("DD") W Y,"."
.S DIR(0)="Y",DIR("A")="Are you sure you want to add a new test",DIR("B")="NO" D ^DIR K DIR
.;S DGTTYP="LTC COPAY "
.;W !,$S($P($G(^DG(408.34,+$P($G(^DGMT(408.31,+DGLDT,0)),U,23),0)),U)="VAMC":" Use the 'EASEC "_DGTTYP_"TEST EDIT' Option.",1:" Use the 'EASEC "_DGTTYP_"TEST VIEW' Option.")
;
D ADD G EN:DGMTI<0
;
EXMPT ; Is veteran exempt from LTC copayments?
S DGEXMPT=$$EXMPT^EASECU(DFN)
I DGEXMPT D EXMPT^EASECSCC(DFN,DGMTI,DGEXMPT) D Q G EN
; Is veteran exempt for reason other than low income?
; LTC Phase IV (EAS*1*40)
W !!
S DIR("A")="Is veteran EXEMPT from LTC copayments",DIR("B")="NO",DIR(0)="Y",DIR("?")="Enter either 'Y' or 'N'."
S DIR("?",1)="Answer 'Yes' if the veteran is exempt from LTC copayments"
S DIR("?",2)="for a reason other than low income.",DIR("?",3)=""
D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D DEL,Q G EN
I Y D D Q G EN
.; Get reason for exemption
.S DIR("A")="Reason for Exemption",DIR(0)="P^714.1:EM"
.S DIR("S")="I $P(^(0),U,2),""^1^2^12^14^""'[(U_Y_U)" ;EAS*1.0*174 HM exclude 14 also
.D ^DIR K DIR I 'Y!($D(DUOUT))!($D(DTOUT)) D D DEL Q
..W !!,"A reason for exemption must be entered. LTC Copay Test cannot be added.",!
.D EXMPT^EASECSCC(DFN,DGMTI,+Y)
; Check if veteran's income is below the pension threshold
D EN^EASECMT I $G(DGOUT) D DEL,Q G EN
I DGEXMPT D EXMPT^EASECSCC(DFN,DGMTI,2) D Q G EN
W !! F I=1:1:80 W "="
W !!,?10,"Veteran is NOT EXEMPT from Long Term Care copayments based"
W !,?10,"on last year's income and must complete a 10-10EC form."
W !! F I=1:1:80 W "="
; Does veteran decline to provide income information?
W !!
D REF^EASECSCC I $D(DTOUT)!($D(DUOUT)) D Q G EN
I $D(DGREF) D D Q G EN
.; Ask if veteran agrees to pay copayments; complete LTC copay test
.D AGREE^EASECSCC Q:$D(DTOUT)!($D(DUOUT))
.S DGSTA="NON-EXEMPT",DGCAT="T" D STA^DGMTSCU2 S (DGINT,DGDET,DGNWT)=""
.D UPD^EASECSCC
; Go to LTC co-pay test (1010-EC) input screens
S DGMTACT="ADD",DGMTROU="EN^EASECA" G EN^EASECSC
;
Q K DA,DFN,DGADDF,DGBL,DGCAT,DGEXMPT,DGFL,DGFLD,DGIRO,DGLD,DGLDT,DGLDYR
K DGMTACT,DGMTCOR,DGMTDT,DGMTI,DGMTROU,DGMTYPT,DGOUT,DGREQF,DGSTA
K DGTTYP,DGVI,DGVO,DTOUT,DUOUT,X,X1,X2,Y
Q
;
ADD ;Add LTC Copay test
; Input -- DFN Patient IEN
; DGMTDT Date
; DGMTYPT Type of Test 3 = LTC Copay
; Output -- DGMTI Annual LTC Copay Test IEN
N DA,DD,DIC,DIK,DINUM,DLAYGO,DO,DS,X,D0,DGSITE
;
S X=DGMTDT,(DIC,DIK)="^DGMT(408.31,",DIC(0)="L",DLAYGO=408.31
S DGSITE=$$GETSITE^DGMTU4(.DUZ)
; For LTC IV (EAS*1*40) - set 1010EC Form field (#2.1) = 1
S DIC("DR")=".02////"_DFN_";.019////"_DGMTYPT_";.23////1;2.05////"_DGSITE_";2.1////1"
K DD,D0
D FILE^DICN S DGMTI=+Y
ADDQ Q
;
DEL ;Delete incomplete LTC Copay test
; Input -- DGMTI LTC Copay test IEN
N DA,DIK
Q:'$G(DGMTI) Q:$P($G(^DGMT(408.31,DGMTI,0)),U,19)'=3
S DA=DGMTI,DIK="^DGMT(408.31,"
D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASECA 4077 printed Oct 16, 2024@17:54:36 Page 2
EASECA ;ALB/PHH,LBD,HM - Add a New LTC Co-Pay Test ;10 AUG 2001
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40,174**;Mar 15, 2001;Build 26
+2 ;
EN ;Entry point to add a new LTC Co-Pay test
+1 NEW DGMDOD
SET DGMDOD=""
+2 SET DGMTYPT=3
+3 IF $DATA(DGMTDFN)#2
KILL DGMTDFN
+4 SET DIC="^DPT("
SET DIC(0)="AEMQ"
WRITE !!
DO ^DIC
KILL DIC
if Y<0
GOTO Q
SET (DFN,DGMTDFN)=+Y
+5 IF $PIECE($GET(^DPT(DFN,.35)),U)'=""
SET DGMDOD=$PIECE(^DPT(DFN,.35),U)
+6 IF $GET(DGMDOD)
WRITE !!,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D")
QUIT
+7 ; Is patient a veteran? Added for LTC III (EAS*1*34)
+8 IF $PIECE($GET(^DPT(DFN,"VET")),U)'="Y"
WRITE !!,"Patient is not a Veteran."
QUIT
+9 ;
+10 SET DGLDT=$$LST^EASECU(DFN,"",DGMTYPT)
SET DGLD=$PIECE(DGLDT,U,2)
SET DGLDYR=$EXTRACT(DGLD,1,3)_"1231"
+11 ;
DT SET %DT("A")="Date of LTC Copay Test: "
SET %DT="AEX"
SET %DT(0)="-NOW"
SET %DT("B")="NOW"
WRITE !
DO ^%DT
KILL %DT
if Y<0
GOTO Q
SET DGMTDT=Y
+1 IF DGLD
IF DGMTDT'>DGLD
WRITE !?3,*7,"The date of test must be after the date of the last test on "
SET Y=DGLD
XECUTE ^DD("DD")
WRITE Y,"."
GOTO DT
+2 ; LTC III (EAS*1*34) - change to allow multiple tests within a year
+3 IF DGLD
SET X1=DGMTDT
SET X2=DGLD
DO ^%DTC
IF X<365
Begin DoDot:1
+4 WRITE !?3,*7,"An LTC Copay Test already exists on "
SET Y=DGLD
XECUTE ^DD("DD")
WRITE Y,"."
+5 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to add a new test"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+6 ;S DGTTYP="LTC COPAY "
+7 ;W !,$S($P($G(^DG(408.34,+$P($G(^DGMT(408.31,+DGLDT,0)),U,23),0)),U)="VAMC":" Use the 'EASEC "_DGTTYP_"TEST EDIT' Option.",1:" Use the 'EASEC "_DGTTYP_"TEST VIEW' Option.")
End DoDot:1
if $GET(Y)'=1
GOTO EN
+8 ;
+9 DO ADD
if DGMTI<0
GOTO EN
+10 ;
EXMPT ; Is veteran exempt from LTC copayments?
+1 SET DGEXMPT=$$EXMPT^EASECU(DFN)
+2 IF DGEXMPT
DO EXMPT^EASECSCC(DFN,DGMTI,DGEXMPT)
DO Q
GOTO EN
+3 ; Is veteran exempt for reason other than low income?
+4 ; LTC Phase IV (EAS*1*40)
+5 WRITE !!
+6 SET DIR("A")="Is veteran EXEMPT from LTC copayments"
SET DIR("B")="NO"
SET DIR(0)="Y"
SET DIR("?")="Enter either 'Y' or 'N'."
+7 SET DIR("?",1)="Answer 'Yes' if the veteran is exempt from LTC copayments"
+8 SET DIR("?",2)="for a reason other than low income."
SET DIR("?",3)=""
+9 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
DO DEL
DO Q
GOTO EN
+10 IF Y
Begin DoDot:1
+11 ; Get reason for exemption
+12 SET DIR("A")="Reason for Exemption"
SET DIR(0)="P^714.1:EM"
+13 ;EAS*1.0*174 HM exclude 14 also
SET DIR("S")="I $P(^(0),U,2),""^1^2^12^14^""'[(U_Y_U)"
+14 DO ^DIR
KILL DIR
IF 'Y!($DATA(DUOUT))!($DATA(DTOUT))
Begin DoDot:2
+15 WRITE !!,"A reason for exemption must be entered. LTC Copay Test cannot be added.",!
End DoDot:2
DO DEL
QUIT
+16 DO EXMPT^EASECSCC(DFN,DGMTI,+Y)
End DoDot:1
DO Q
GOTO EN
+17 ; Check if veteran's income is below the pension threshold
+18 DO EN^EASECMT
IF $GET(DGOUT)
DO DEL
DO Q
GOTO EN
+19 IF DGEXMPT
DO EXMPT^EASECSCC(DFN,DGMTI,2)
DO Q
GOTO EN
+20 WRITE !!
FOR I=1:1:80
WRITE "="
+21 WRITE !!,?10,"Veteran is NOT EXEMPT from Long Term Care copayments based"
+22 WRITE !,?10,"on last year's income and must complete a 10-10EC form."
+23 WRITE !!
FOR I=1:1:80
WRITE "="
+24 ; Does veteran decline to provide income information?
+25 WRITE !!
+26 DO REF^EASECSCC
IF $DATA(DTOUT)!($DATA(DUOUT))
DO Q
GOTO EN
+27 IF $DATA(DGREF)
Begin DoDot:1
+28 ; Ask if veteran agrees to pay copayments; complete LTC copay test
+29 DO AGREE^EASECSCC
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+30 SET DGSTA="NON-EXEMPT"
SET DGCAT="T"
DO STA^DGMTSCU2
SET (DGINT,DGDET,DGNWT)=""
+31 DO UPD^EASECSCC
End DoDot:1
DO Q
GOTO EN
+32 ; Go to LTC co-pay test (1010-EC) input screens
+33 SET DGMTACT="ADD"
SET DGMTROU="EN^EASECA"
GOTO EN^EASECSC
+34 ;
Q KILL DA,DFN,DGADDF,DGBL,DGCAT,DGEXMPT,DGFL,DGFLD,DGIRO,DGLD,DGLDT,DGLDYR
+1 KILL DGMTACT,DGMTCOR,DGMTDT,DGMTI,DGMTROU,DGMTYPT,DGOUT,DGREQF,DGSTA
+2 KILL DGTTYP,DGVI,DGVO,DTOUT,DUOUT,X,X1,X2,Y
+3 QUIT
+4 ;
ADD ;Add LTC Copay test
+1 ; Input -- DFN Patient IEN
+2 ; DGMTDT Date
+3 ; DGMTYPT Type of Test 3 = LTC Copay
+4 ; Output -- DGMTI Annual LTC Copay Test IEN
+5 NEW DA,DD,DIC,DIK,DINUM,DLAYGO,DO,DS,X,D0,DGSITE
+6 ;
+7 SET X=DGMTDT
SET (DIC,DIK)="^DGMT(408.31,"
SET DIC(0)="L"
SET DLAYGO=408.31
+8 SET DGSITE=$$GETSITE^DGMTU4(.DUZ)
+9 ; For LTC IV (EAS*1*40) - set 1010EC Form field (#2.1) = 1
+10 SET DIC("DR")=".02////"_DFN_";.019////"_DGMTYPT_";.23////1;2.05////"_DGSITE_";2.1////1"
+11 KILL DD,D0
+12 DO FILE^DICN
SET DGMTI=+Y
ADDQ QUIT
+1 ;
DEL ;Delete incomplete LTC Copay test
+1 ; Input -- DGMTI LTC Copay test IEN
+2 NEW DA,DIK
+3 if '$GET(DGMTI)
QUIT
if $PIECE($GET(^DGMT(408.31,DGMTI,0)),U,19)'=3
QUIT
+4 SET DA=DGMTI
SET DIK="^DGMT(408.31,"
+5 DO ^DIK
+6 QUIT
