EASECE ;ALB/PHH,LBD - Edit an Existing LTC Co-Pay Test ;17 AUG 2001
;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40**;Mar 15, 2001
;
EN ;Entry point to edit an existing LTC co-pay test
N DGMDOD S DGMDOD="",DGMTYPT=3
S DIC("S")="I $D(^DGMT(408.31,""AID"",DGMTYPT,+Y))"
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
;
DT S DIC("A")="Select DATE OF LTC COPAY TEST: "
I $D(^DGMT(408.31,+$$LST^EASECU(DFN,"",DGMTYPT),0)) S DIC("B")=$P(^(0),"^")
S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT"
S DIC="^DGMT(408.31,",DIC(0)="EQZ" W ! D EN^DGMTLK K DIC G Q:Y<0
S DGMTI=+Y,DGMTDT=$P(Y,"^",2),DGMT0=Y(0)
;
;If test is uneditable, print error message and allow user to view test
;or print 10/10EC
;
I '$P($G(^DG(408.34,+$P(Y(0),U,23),0)),U,2) D D:$G(DGMTERR) VIEWPRT G EN
.W !!?3,*7,"Warning: Uneditable LTC Copay test. The source of this test is "_$S($$SR^DGMTAUD1(Y(0))]"":$$SR^DGMTAUD1(Y(0)),1:"UNKNOWN")
.W !?12,"which has been flagged as an uneditable source.",!
.S DIR("A")="Would you like to view the LTC Copay test or print the 10-10EC",DIR("B")="NO",DIR(0)="Y"
.D ^DIR K DIR S DGMTERR=Y I $D(DTOUT)!($D(DUOUT)) K DGMTERR,DTOUT,DUOUT
;
; If user holds DG MTDELETE security key, allow test date to be edited.
; LTC III (EAS*1*34)
I $D(^XUSEC("DG MTDELETE",+$G(DUZ))) D
.N DIR,DA,DR,DIE,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,DGNEWDT
.S DIR(0)="D^:DT:EX",DIR("A")="DATE OF TEST",DIR("B")=$$FMTE^XLFDT(DGMTDT,1)
.S DIR("?")="Enter a date that is less than or equal to today."
.S DIR("?",1)="Enter the date of the LTC Copay Test."
.D ^DIR K DIR Q:'Y!(Y=DGMTDT) S DGNEWDT=Y
.S DIR(0)="Y",DIR("A")="Are you sure you want to change the date of the LTC Copay Test",DIR("B")="NO" D ^DIR Q:'Y
.S DIE="^DGMT(408.31,",DA=DGMTI,DR=".01////"_DGNEWDT_";2.02///NOW"
.D ^DIE
;
EXMPT ; Is veteran exempt?
S DGEXMPT=$$EXMPT^EASECU(DFN)
I DGEXMPT D EXMPT^EASECSCC(DFN,DGMTI,DGEXMPT) D Q G EN
;
D DISPLAY^EASECU23(DGMTI,DGMTYPT),PAUSE I $D(DTOUT)!($D(DUOUT)) K DTOUT,DUOUT G EN
;
; Allow user to edit LTC copay test status or reason for exemption.
; If veteran is exempt for reason other than low income, don't do
; income check. Added for LTC Phase IV (EAS*1*40)
W ! S DGEFLG=1 D STA^EASECSCC K DGEFLG
I $G(DGSTA)="EXEMPT",$G(DGRE),"^2^12^"'[(U_DGRE_U) D EXMPT^EASECSCC(DFN,DGMTI,DGRE) D Q G EN
S DGNSTA=$G(DGSTA)
;
; Check if veteran's income is below the pension threshold
D EN^EASECMT I $G(DGOUT) D Q G EN
I DGEXMPT D EXMPT^EASECSCC(DFN,DGMTI,2) D Q G EN
S DGMT0=$G(^DGMT(408.31,DGMTI,0)) F I=4,5,15 I $P(DGMT0,U,I) G EDT
; Display message for vets who declined to provide income info
; LTC III (EAS*1*34)
I $P(DGMT0,U,14)=1 D
.W !! F I=1:1:80 W "="
.W !!,?10,"Veteran is NOT EXEMPT from Long Term Care copayments and"
.W !,?10,"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
;
EDT S DGMTACT="EDT",DGMTROU="EN^EASECE" G EN^EASECSC
;
Q K DFN,DGEXMPT,DGMTACT,DGMTDT,DGMTERR,DGMT0,DGMTI,DGMTROU,DGMTYPT,DGMTX,DGOUT,DTOUT,DUOUT,X,Y
K DGREF,DGSTA,DGCAT,DGINT,DGDET,DGNWT,I,DGFORM,DGMTS,DGRE,DGNSTA
Q
;
PAUSE S DIR(0)="E" D ^DIR
Q
;
VIEWPRT ; Select 1 to view an uneditable means test or 2 to print a 10/10EC
;
S DIR(0)="S^1:View LTC Copay Test;2:Print LTC Copay Test 10-10EC",DIR("A")="Select Choice"
D ^DIR S DGMTANS=Y G:$D(DTOUT)!($D(DUOUT)) VIEWPRTQ
I DGMTANS=1 D EN1^EASECV
I DGMTANS=2 D OEN^EASEC10E
VIEWPRTQ ;
K DGMTANS,DIR,DTOUT,DUOUT,Y
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASECE 4006 printed Dec 13, 2024@01:53:59 Page 2
EASECE ;ALB/PHH,LBD - Edit an Existing LTC Co-Pay Test ;17 AUG 2001
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40**;Mar 15, 2001
+2 ;
EN ;Entry point to edit an existing LTC co-pay test
+1 NEW DGMDOD
SET DGMDOD=""
SET DGMTYPT=3
+2 SET DIC("S")="I $D(^DGMT(408.31,""AID"",DGMTYPT,+Y))"
+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 ;
DT SET DIC("A")="Select DATE OF LTC COPAY TEST: "
+1 IF $DATA(^DGMT(408.31,+$$LST^EASECU(DFN,"",DGMTYPT),0))
SET DIC("B")=$PIECE(^(0),"^")
+2 SET DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT"
+3 SET DIC="^DGMT(408.31,"
SET DIC(0)="EQZ"
WRITE !
DO EN^DGMTLK
KILL DIC
if Y<0
GOTO Q
+4 SET DGMTI=+Y
SET DGMTDT=$PIECE(Y,"^",2)
SET DGMT0=Y(0)
+5 ;
+6 ;If test is uneditable, print error message and allow user to view test
+7 ;or print 10/10EC
+8 ;
+9 IF '$PIECE($GET(^DG(408.34,+$PIECE(Y(0),U,23),0)),U,2)
Begin DoDot:1
+10 WRITE !!?3,*7,"Warning: Uneditable LTC Copay test. The source of this test is "_$SELECT($$SR^DGMTAUD1(Y(0))]"":$$SR^DGMTAUD1(Y(0)),1:"UNKNOWN")
+11 WRITE !?12,"which has been flagged as an uneditable source.",!
+12 SET DIR("A")="Would you like to view the LTC Copay test or print the 10-10EC"
SET DIR("B")="NO"
SET DIR(0)="Y"
+13 DO ^DIR
KILL DIR
SET DGMTERR=Y
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DGMTERR,DTOUT,DUOUT
End DoDot:1
if $GET(DGMTERR)
DO VIEWPRT
GOTO EN
+14 ;
+15 ; If user holds DG MTDELETE security key, allow test date to be edited.
+16 ; LTC III (EAS*1*34)
+17 IF $DATA(^XUSEC("DG MTDELETE",+$GET(DUZ)))
Begin DoDot:1
+18 NEW DIR,DA,DR,DIE,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,DGNEWDT
+19 SET DIR(0)="D^:DT:EX"
SET DIR("A")="DATE OF TEST"
SET DIR("B")=$$FMTE^XLFDT(DGMTDT,1)
+20 SET DIR("?")="Enter a date that is less than or equal to today."
+21 SET DIR("?",1)="Enter the date of the LTC Copay Test."
+22 DO ^DIR
KILL DIR
if 'Y!(Y=DGMTDT)
QUIT
SET DGNEWDT=Y
+23 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to change the date of the LTC Copay Test"
SET DIR("B")="NO"
DO ^DIR
if 'Y
QUIT
+24 SET DIE="^DGMT(408.31,"
SET DA=DGMTI
SET DR=".01////"_DGNEWDT_";2.02///NOW"
+25 DO ^DIE
End DoDot:1
+26 ;
EXMPT ; Is veteran exempt?
+1 SET DGEXMPT=$$EXMPT^EASECU(DFN)
+2 IF DGEXMPT
DO EXMPT^EASECSCC(DFN,DGMTI,DGEXMPT)
DO Q
GOTO EN
+3 ;
+4 DO DISPLAY^EASECU23(DGMTI,DGMTYPT)
DO PAUSE
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DTOUT,DUOUT
GOTO EN
+5 ;
+6 ; Allow user to edit LTC copay test status or reason for exemption.
+7 ; If veteran is exempt for reason other than low income, don't do
+8 ; income check. Added for LTC Phase IV (EAS*1*40)
+9 WRITE !
SET DGEFLG=1
DO STA^EASECSCC
KILL DGEFLG
+10 IF $GET(DGSTA)="EXEMPT"
IF $GET(DGRE)
IF "^2^12^"'[(U_DGRE_U)
DO EXMPT^EASECSCC(DFN,DGMTI,DGRE)
DO Q
GOTO EN
+11 SET DGNSTA=$GET(DGSTA)
+12 ;
+13 ; Check if veteran's income is below the pension threshold
+14 DO EN^EASECMT
IF $GET(DGOUT)
DO Q
GOTO EN
+15 IF DGEXMPT
DO EXMPT^EASECSCC(DFN,DGMTI,2)
DO Q
GOTO EN
+16 SET DGMT0=$GET(^DGMT(408.31,DGMTI,0))
FOR I=4,5,15
IF $PIECE(DGMT0,U,I)
GOTO EDT
+17 ; Display message for vets who declined to provide income info
+18 ; LTC III (EAS*1*34)
+19 IF $PIECE(DGMT0,U,14)=1
Begin DoDot:1
+20 WRITE !!
FOR I=1:1:80
WRITE "="
+21 WRITE !!,?10,"Veteran is NOT EXEMPT from Long Term Care copayments and"
+22 WRITE !,?10,"must complete a 10-10EC form."
+23 WRITE !!
FOR I=1:1:80
WRITE "="
End DoDot:1
+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 ;
EDT SET DGMTACT="EDT"
SET DGMTROU="EN^EASECE"
GOTO EN^EASECSC
+1 ;
Q KILL DFN,DGEXMPT,DGMTACT,DGMTDT,DGMTERR,DGMT0,DGMTI,DGMTROU,DGMTYPT,DGMTX,DGOUT,DTOUT,DUOUT,X,Y
+1 KILL DGREF,DGSTA,DGCAT,DGINT,DGDET,DGNWT,I,DGFORM,DGMTS,DGRE,DGNSTA
+2 QUIT
+3 ;
PAUSE SET DIR(0)="E"
DO ^DIR
+1 QUIT
+2 ;
VIEWPRT ; Select 1 to view an uneditable means test or 2 to print a 10/10EC
+1 ;
+2 SET DIR(0)="S^1:View LTC Copay Test;2:Print LTC Copay Test 10-10EC"
SET DIR("A")="Select Choice"
+3 DO ^DIR
SET DGMTANS=Y
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO VIEWPRTQ
+4 IF DGMTANS=1
DO EN1^EASECV
+5 IF DGMTANS=2
DO OEN^EASEC10E
VIEWPRTQ ;
+1 KILL DGMTANS,DIR,DTOUT,DUOUT,Y
+2 QUIT
+3 ;
