EASECMT ;ALB/LBD,BDB - Means Test for LTC Co-Pay exemption ; 27 DEC 2001
;;1.0;ENROLLMENT APPLICATION SYSTEM;**7,16,18,70,88,106**;Mar 15, 2001;Build 28
;
EN ; This is the entry point for the routine that will find the
; financial test for a veteran that can be used to check if
; veteran's income is below the threshold and exempt from LTC
; co-payments. If a financial test is not on file for the veteran
; it can be added through this process.
; Input -- DFN = Patient IEN
; Output -- DGEXMPT = 1 (exempt from LTC co-payments)
; = 0 or "" (not exempt from LTC co-payments)
; DGOUT = 1 (user wants to exit from the process)
N DGCMPLT,DGMTI,DGMTDT,DGMTYPT,DGMTACT,DGL,DGCS,DGMSGF,DGREQF,DGDOM,DGDOM1,Y
; Does veteran have current LTC co-pay exemption test (type 4)?
S Y=$$GETLTC4(DFN) I Y S DGEXMPT=$S($P(Y,U,3)="EXEMPT":1,1:0) Q
; Does veteran have current means test?
S DGL=$$LST^DGMTU(DFN),DGMTI=+DGL,DGMTDT=$P(DGL,U,2),DGCS=$P(DGL,U,4)
; If last means test has status of Cat C or Pend. Adj. and vet agreed
; to pay MT copay, new means test is not required
I ((DGCS="C")!(DGCS="P")),$P($G(^DGMT(408.31,DGMTI,0)),U,11)=1,DGMTDT>2991005 S DGEXMPT=0 D LTC4(DGMTI,DGEXMPT) Q
; If means test is required or more than a year old, do new means test
; EAS*1.0*106 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
I (DGCS="R")!($$OLDMTPF^DGMTU4(DGMTDT)) D Q:$G(DGOUT)!(DGMTYPT=4)
.S (DGADDF,DGMSGF)=1 D ^DGMTR S DGMTYPT=$S(DGREQF:1,1:4)
.I '$$ASK(DGMTYPT) S DGOUT=1 Q
.S DGMTACT="ADD" I DGMTYPT=1,$E(DGMTDT,1,3)=$E(DT,1,3) S DGMTACT="EDT"
.D MT(DFN,DGMTYPT,DGMTACT,.DGMTI,.DGCMPLT)
.I '$G(DGCMPLT) S DGOUT=1 Q
.I DGMTYPT=4 D
..D DOM^DGMTR I '$G(DGDOM1) D COPYRX^DGMTR1(DFN,DGMTI)
..S Y=$$GETCODE^DGMTH($P($G(^DGMT(408.31,DGMTI,0)),U,3)),DGEXMPT=$S(Y=0:1,1:0)
; If no means test or means test is no longer required, check if
; there is an RX co-pay test, otherwise do new LTC co-pay exemption test
I DGCS=""!(DGCS="N") D Q:$G(DGOUT)!($G(DGMTYPT)=4)
.S DGL=$$LST^DGMTU(DFN,DT,2),DGMTI=+DGL,DGMTDT=$P(DGL,U,2),DGCS=$P(DGL,U,4)
.I DGMTI,'$$OLD^DGMTU4(DGMTDT),("^I^L^")'[("^"_DGCS_"^") Q
.S DGMTYPT=4
.I '$$ASK(DGMTYPT) S DGOUT=1 Q
.D MT(DFN,DGMTYPT,"ADD",.DGMTI,.DGCMPLT)
.I '$G(DGCMPLT) S DGOUT=1 Q
.D DOM^DGMTR I '$G(DGDOM1) D COPYRX^DGMTR1(DFN,DGMTI)
.S Y=$$GETCODE^DGMTH($P($G(^DGMT(408.31,DGMTI,0)),U,3))
.S DGEXMPT=$S(Y=0:1,1:0)
; Check if veteran's income is below the pension threshold
S DGEXMPT=$$THRES(DFN,DGMTDT)
I DGEXMPT<0 W !!,"The income threshold check could not be completed due to an error." S DGOUT=1 Q
; Create LTC co-pay exemption test (type 4) by copying MT
D LTC4(DGMTI,DGEXMPT)
Q
;
THRES(DFN,DGMTDT) ; Is veteran's income below the pension threshold
; Input - DFN = Patient IEN
; DGMTDT = Test date
; Output - = 1 (Below the threshold)
; = 0 (Above the threshold)
; = -1(Error)
N DGDC,DGDEP,DGDET,DGERR,DGIN0,DGIN1,DGIN2,DGINI,DGINT,DGINTF,DGIRI
N DGNC,DGND,DGNWT,DGNWTF,DGPRI,DGSP,DGVINI,DGVIR0,DGVIRI,DGTHRES
N DGLY,DGMTPAR
; Get current single veteran pension threshold amount
S DGTHRES=$$THRES^IBARXEU1(DGMTDT,1,0) I '+DGTHRES Q -1
; Calculate veteran's income level and check against the threshold
S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0)) I 'DGPRI Q -1
D GETIENS^DGMTU2(DFN,DGPRI,DGMTDT) I '$G(DGIRI),'$G(DGINI) Q -1
S DGVIRI=DGIRI,DGVINI=DGINI
S DGLY=$$LYR^DGMTSCU1(DGMTDT) D PAR^DGMTSCU
D DEP^DGMTSCU2,INC^DGMTSCU3 I '$D(DGINT) Q -1
; If vet declined to provide financial info, return 0 (above threshold)
I $P($G(^DGMT(408.31,+$G(DGMTI),0)),U,14) Q 0
I (DGINT-DGDET)'>+DGTHRES Q 1
Q 0
;
MT(DFN,TYPE,ACT,DGMTI,DGCMPLT) ; Complete a means test or LTC co-pay exemption test
; Input - DFN = Patient IEN
; TYPE = Type of test (1=MT; 4=LTC4)
; ACT = Type of action (ADD or EDT)
; DGMTI = If EDT action, IEN of test to be edited
; Output - DGCMPLT = 1 (MT completed)
; = 0 (MT not completed)
; DGMTI = IEN of new test
N DGMTYPT,DGMTACT,DGMTROU,DGMT0,DGSTA,TYPESAVE,DGCMPLT
S DGCMPLT=0
I $$LOCK^DGMTUTL(DFN) E Q DGCMPLT
S DGMTYPT=TYPE,DGMTACT=ACT
S TYPESAVE=TYPE ;*GTS - EAS*1*70
S DGMTDT=$S(DGMTACT="EDT":+$G(^DGMT(408.31,DGMTI,0)),1:DT) I 'DGMTDT D MT1 Q
;*GTS - EAS*1*70
; If adding a LTC CP Exemption test, TYPE indicates test copied from for ADD^DGMTA
I DGMTACT="ADD" S:TYPE=4 TYPE=1 D ADD^DGMTA S TYPE=TYPESAVE I '$G(DGMTI) D MT1 Q
S DGMTROU="MT1^EASECMT"
G EN^DGMTSC
MT1 I $G(DGMTI) D
.S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGSTA=$$GETCODE^DGMTH($P(DGMT0,U,3))
.I DGSTA'="","ACP01"[DGSTA,$P(DGMT0,U,7)]"" S DGCMPLT=1
.I 'DGCMPLT,TYPE=4 D DEL ;Delete incomplete LTC copay exemption test
D UNLOCK^DGMTUTL(DFN)
Q
;
LTC4(DGMT,DGEXMPT) ; Create or update LTC copay exemption test (type 4) by copying
; means test
; Input - DGMT = Annual Means Test IEN of test to be copied
; - DGEXMPT = LTC copayments exemption status (optional)
Q:'DGMT
N DGMT0,DGMT2,DA,DIC,DIK,DLAYGO,X,DFN,DGMTI,DGCONVRT
N DGMTA,DGMTP,DGMTACT,DGMTINF,DGMTYPT
; Quit if this is a LTC copay exemption test (type 4)
S DGMT0=$G(^DGMT(408.31,DGMT,0)) I $P(DGMT0,U,19)=4 Q
S DGMT2=$G(^DGMT(408.31,DGMT,2))
; Add a new LTC 4 test or edit an existing LTC 4 test?
S DGMTI=$O(^DGMT(408.31,"AT",DGMT,0))
S DGMTACT=$S(DGMTI:"EDT",1:"ADD")
S DGMTP="" I DGMTACT="EDT" S DGMTP=$G(^DGMT(408.31,DGMTI,0))
S DFN=$P(DGMT0,U,2)
; Add new entry to Annual Means Test file (#408.31) for LTC 4 test
I DGMTACT="ADD" D Q:DGMTI'>0
.S X=+DGMT0,(DIC,DIK)="^DGMT(408.31,",DIC(0)="L",DLAYGO=408.31
.D FILE^DICN S DGMTI=+Y
.;*GTS - EAS*1*70
.S DGCONVRT=$$VRCHKUP^DGMTU2(4,$P(DGMT0,"^",19),+DGMT0,+DGMT0)
.S DATA(2.11)=1
F I=.01,.02,.04,.05,.06,.11,.14,.15,.18,.23 S DATA(I)=$P(DGMT0,U,(I/.01))
I '$D(DGEXMPT) S DGEXMPT=$$THRES(DFN,$P(DGMT0,U,1))
S DATA(.03)=$S(DGEXMPT:15,1:14),DATA(.07)=DT
S DATA(.019)=4,DATA(2.02)=$P(DGMT2,U,2),DATA(2.08)=DGMT
S DATA(2.05)=$P(DGMT2,U,5)
I $$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
K DATA,ERROR
; Update the LTC copay test (type 3), if status changed
I DGMTACT="EDT" D UPLTC3(DGMTI)
; Update Audit file and IVM Patient file
S DGMTYPT=4,DGMTINF=1 D AFTER^DGMTEVT
D EN^DGMTAUD
D EN^IVMPMTE
Q
;
ASK(TYPE) ; Does user want to perform MT/LTC4 test now?
; Input - TYPE = Type of test, 1: MT; 4: LTC Copay Exemption
; Output - Y = 1 (YES)
; = 0 (NO)
N DIR,TST
S TST=$S(TYPE=1:"Means Test",1:"LTC Copay Exemption Test")
W !!,"The previous year's financial information is not on file for this veteran.",!,"A ",TST," is required."
S DIR("A")="Do you wish to complete the "_TST_" at this time"
S DIR("B")="NO",DIR(0)="Y"
W ! D ^DIR
Q +(Y)
;
GETLTC4(DFN,DGMTDT) ; Return last LTC co-pay exemption test (type 4),
; if less than a year old
; Input - DFN = Patient IEN
; DGMTDT (optional) = Date of test
; Output - Y = Annual Means Test IEN^Date of Test^Status Name^
; Status Code^Source of Test
; = "" (no current LTC co-pay exemption test)
N Y
S Y="" Q:'$G(DFN) Y I '$G(DGMTDT) S DGMTDT=DT
S Y=$$LST^DGMTU(DFN,DGMTDT,4) I '(+Y) Q Y
I $$OLD^DGMTU4($P(Y,U,2)) S Y=""
Q Y
;
DEL ;Delete incomplete LTC Copay Exemption test (type 4)
; Input -- DGMTI LTC Copay Exemption test IEN
N DA,DIK,DIE,DR,V
Q:'$G(DGMTI) Q:$P($G(^DGMT(408.31,DGMTI,0)),U,19)'=4
; Delete pointer in Income Relation file (#408.22)
I $D(^DGMT(408.22,"AMT",DGMTI)) D
.S DIE="^DGMT(408.22,",DR="31///@"
.S V=$O(^DGMT(408.22,"AMT",DGMTI,0)) Q:'V
.S IR=0 F S IR=$O(^DGMT(408.22,"AMT",DGMTI,V,IR)) Q:'IR S DA=$O(^(IR,0)) I DA D ^DIE
; Delete LTC Copay Exemption test from Annual Means Test file (#408.31)
S DA=DGMTI,DIK="^DGMT(408.31,"
D ^DIK
Q
;
UPLTC3(DGMT4) ;If the status of a LTC Copay Exemption test (type 4) changes,
;update the status of the LTC Copay test (type 3), if necessary
; Input -- DGMT4 LTC Copay Exemption test IEN
N DGMT3,DGMTS4,DGMTS3,DGS,DATA,ERROR
Q:'DGMT4
S DGMT3=$O(^DGMT(408.31,"AT",DGMT4,0)) Q:$G(^DGMT(408.31,+DGMT3,0))=""
; Get test status
S DGMTS4=$$GETNAME^DGMTH($P(^DGMT(408.31,DGMT4,0),U,3))
S DGMTS3=$$GETNAME^DGMTH($P(^DGMT(408.31,DGMT3,0),U,3))
; If test status is the same quit
I DGMTS4=DGMTS3 Q
; If LTC copay test (type 3) is Exempt and the Reason for Exemption is
; anything other than 2 (Income Last Year Below Threshold), quit
I DGMTS3="EXEMPT",$P($G(^DGMT(408.31,DGMT3,2)),U,7)'=2 Q
; Get IEN of Means Test Status and update LTC copay test
S DGS="" F S DGS=$O(^DG(408.32,"B",DGMTS4,DGS)) Q:'DGS I $P(^DG(408.32,DGS,0),U,19)=3 Q
S DATA(.03)=DGS,DATA(2.07)=$S(DGMTS4="EXEMPT":2,1:"@")
I $$UPD^DGENDBS(408.31,DGMT3,.DATA,.ERROR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASECMT 8983 printed Sep 23, 2025@19:30:10 Page 2
EASECMT ;ALB/LBD,BDB - Means Test for LTC Co-Pay exemption ; 27 DEC 2001
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**7,16,18,70,88,106**;Mar 15, 2001;Build 28
+2 ;
EN ; This is the entry point for the routine that will find the
+1 ; financial test for a veteran that can be used to check if
+2 ; veteran's income is below the threshold and exempt from LTC
+3 ; co-payments. If a financial test is not on file for the veteran
+4 ; it can be added through this process.
+5 ; Input -- DFN = Patient IEN
+6 ; Output -- DGEXMPT = 1 (exempt from LTC co-payments)
+7 ; = 0 or "" (not exempt from LTC co-payments)
+8 ; DGOUT = 1 (user wants to exit from the process)
+9 NEW DGCMPLT,DGMTI,DGMTDT,DGMTYPT,DGMTACT,DGL,DGCS,DGMSGF,DGREQF,DGDOM,DGDOM1,Y
+10 ; Does veteran have current LTC co-pay exemption test (type 4)?
+11 SET Y=$$GETLTC4(DFN)
IF Y
SET DGEXMPT=$SELECT($PIECE(Y,U,3)="EXEMPT":1,1:0)
QUIT
+12 ; Does veteran have current means test?
+13 SET DGL=$$LST^DGMTU(DFN)
SET DGMTI=+DGL
SET DGMTDT=$PIECE(DGL,U,2)
SET DGCS=$PIECE(DGL,U,4)
+14 ; If last means test has status of Cat C or Pend. Adj. and vet agreed
+15 ; to pay MT copay, new means test is not required
+16 IF ((DGCS="C")!(DGCS="P"))
IF $PIECE($GET(^DGMT(408.31,DGMTI,0)),U,11)=1
IF DGMTDT>2991005
SET DGEXMPT=0
DO LTC4(DGMTI,DGEXMPT)
QUIT
+17 ; If means test is required or more than a year old, do new means test
+18 ; EAS*1.0*106 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
+19 IF (DGCS="R")!($$OLDMTPF^DGMTU4(DGMTDT))
Begin DoDot:1
+20 SET (DGADDF,DGMSGF)=1
DO ^DGMTR
SET DGMTYPT=$SELECT(DGREQF:1,1:4)
+21 IF '$$ASK(DGMTYPT)
SET DGOUT=1
QUIT
+22 SET DGMTACT="ADD"
IF DGMTYPT=1
IF $EXTRACT(DGMTDT,1,3)=$EXTRACT(DT,1,3)
SET DGMTACT="EDT"
+23 DO MT(DFN,DGMTYPT,DGMTACT,.DGMTI,.DGCMPLT)
+24 IF '$GET(DGCMPLT)
SET DGOUT=1
QUIT
+25 IF DGMTYPT=4
Begin DoDot:2
+26 DO DOM^DGMTR
IF '$GET(DGDOM1)
DO COPYRX^DGMTR1(DFN,DGMTI)
+27 SET Y=$$GETCODE^DGMTH($PIECE($GET(^DGMT(408.31,DGMTI,0)),U,3))
SET DGEXMPT=$SELECT(Y=0:1,1:0)
End DoDot:2
End DoDot:1
if $GET(DGOUT)!(DGMTYPT=4)
QUIT
+28 ; If no means test or means test is no longer required, check if
+29 ; there is an RX co-pay test, otherwise do new LTC co-pay exemption test
+30 IF DGCS=""!(DGCS="N")
Begin DoDot:1
+31 SET DGL=$$LST^DGMTU(DFN,DT,2)
SET DGMTI=+DGL
SET DGMTDT=$PIECE(DGL,U,2)
SET DGCS=$PIECE(DGL,U,4)
+32 IF DGMTI
IF '$$OLD^DGMTU4(DGMTDT)
IF ("^I^L^")'[("^"_DGCS_"^")
QUIT
+33 SET DGMTYPT=4
+34 IF '$$ASK(DGMTYPT)
SET DGOUT=1
QUIT
+35 DO MT(DFN,DGMTYPT,"ADD",.DGMTI,.DGCMPLT)
+36 IF '$GET(DGCMPLT)
SET DGOUT=1
QUIT
+37 DO DOM^DGMTR
IF '$GET(DGDOM1)
DO COPYRX^DGMTR1(DFN,DGMTI)
+38 SET Y=$$GETCODE^DGMTH($PIECE($GET(^DGMT(408.31,DGMTI,0)),U,3))
+39 SET DGEXMPT=$SELECT(Y=0:1,1:0)
End DoDot:1
if $GET(DGOUT)!($GET(DGMTYPT)=4)
QUIT
+40 ; Check if veteran's income is below the pension threshold
+41 SET DGEXMPT=$$THRES(DFN,DGMTDT)
+42 IF DGEXMPT<0
WRITE !!,"The income threshold check could not be completed due to an error."
SET DGOUT=1
QUIT
+43 ; Create LTC co-pay exemption test (type 4) by copying MT
+44 DO LTC4(DGMTI,DGEXMPT)
+45 QUIT
+46 ;
THRES(DFN,DGMTDT) ; Is veteran's income below the pension threshold
+1 ; Input - DFN = Patient IEN
+2 ; DGMTDT = Test date
+3 ; Output - = 1 (Below the threshold)
+4 ; = 0 (Above the threshold)
+5 ; = -1(Error)
+6 NEW DGDC,DGDEP,DGDET,DGERR,DGIN0,DGIN1,DGIN2,DGINI,DGINT,DGINTF,DGIRI
+7 NEW DGNC,DGND,DGNWT,DGNWTF,DGPRI,DGSP,DGVINI,DGVIR0,DGVIRI,DGTHRES
+8 NEW DGLY,DGMTPAR
+9 ; Get current single veteran pension threshold amount
+10 SET DGTHRES=$$THRES^IBARXEU1(DGMTDT,1,0)
IF '+DGTHRES
QUIT -1
+11 ; Calculate veteran's income level and check against the threshold
+12 SET DGPRI=$ORDER(^DGPR(408.12,"C",DFN_";DPT(",0))
IF 'DGPRI
QUIT -1
+13 DO GETIENS^DGMTU2(DFN,DGPRI,DGMTDT)
IF '$GET(DGIRI)
IF '$GET(DGINI)
QUIT -1
+14 SET DGVIRI=DGIRI
SET DGVINI=DGINI
+15 SET DGLY=$$LYR^DGMTSCU1(DGMTDT)
DO PAR^DGMTSCU
+16 DO DEP^DGMTSCU2
DO INC^DGMTSCU3
IF '$DATA(DGINT)
QUIT -1
+17 ; If vet declined to provide financial info, return 0 (above threshold)
+18 IF $PIECE($GET(^DGMT(408.31,+$GET(DGMTI),0)),U,14)
QUIT 0
+19 IF (DGINT-DGDET)'>+DGTHRES
QUIT 1
+20 QUIT 0
+21 ;
MT(DFN,TYPE,ACT,DGMTI,DGCMPLT) ; Complete a means test or LTC co-pay exemption test
+1 ; Input - DFN = Patient IEN
+2 ; TYPE = Type of test (1=MT; 4=LTC4)
+3 ; ACT = Type of action (ADD or EDT)
+4 ; DGMTI = If EDT action, IEN of test to be edited
+5 ; Output - DGCMPLT = 1 (MT completed)
+6 ; = 0 (MT not completed)
+7 ; DGMTI = IEN of new test
+8 NEW DGMTYPT,DGMTACT,DGMTROU,DGMT0,DGSTA,TYPESAVE,DGCMPLT
+9 SET DGCMPLT=0
+10 IF $$LOCK^DGMTUTL(DFN)
IF '$TEST
QUIT DGCMPLT
+11 SET DGMTYPT=TYPE
SET DGMTACT=ACT
+12 ;*GTS - EAS*1*70
SET TYPESAVE=TYPE
+13 SET DGMTDT=$SELECT(DGMTACT="EDT":+$GET(^DGMT(408.31,DGMTI,0)),1:DT)
IF 'DGMTDT
DO MT1
QUIT
+14 ;*GTS - EAS*1*70
+15 ; If adding a LTC CP Exemption test, TYPE indicates test copied from for ADD^DGMTA
+16 IF DGMTACT="ADD"
if TYPE=4
SET TYPE=1
DO ADD^DGMTA
SET TYPE=TYPESAVE
IF '$GET(DGMTI)
DO MT1
QUIT
+17 SET DGMTROU="MT1^EASECMT"
+18 GOTO EN^DGMTSC
MT1 IF $GET(DGMTI)
Begin DoDot:1
+1 SET DGMT0=$GET(^DGMT(408.31,DGMTI,0))
SET DGSTA=$$GETCODE^DGMTH($PIECE(DGMT0,U,3))
+2 IF DGSTA'=""
IF "ACP01"[DGSTA
IF $PIECE(DGMT0,U,7)]""
SET DGCMPLT=1
+3 ;Delete incomplete LTC copay exemption test
IF 'DGCMPLT
IF TYPE=4
DO DEL
End DoDot:1
+4 DO UNLOCK^DGMTUTL(DFN)
+5 QUIT
+6 ;
LTC4(DGMT,DGEXMPT) ; Create or update LTC copay exemption test (type 4) by copying
+1 ; means test
+2 ; Input - DGMT = Annual Means Test IEN of test to be copied
+3 ; - DGEXMPT = LTC copayments exemption status (optional)
+4 if 'DGMT
QUIT
+5 NEW DGMT0,DGMT2,DA,DIC,DIK,DLAYGO,X,DFN,DGMTI,DGCONVRT
+6 NEW DGMTA,DGMTP,DGMTACT,DGMTINF,DGMTYPT
+7 ; Quit if this is a LTC copay exemption test (type 4)
+8 SET DGMT0=$GET(^DGMT(408.31,DGMT,0))
IF $PIECE(DGMT0,U,19)=4
QUIT
+9 SET DGMT2=$GET(^DGMT(408.31,DGMT,2))
+10 ; Add a new LTC 4 test or edit an existing LTC 4 test?
+11 SET DGMTI=$ORDER(^DGMT(408.31,"AT",DGMT,0))
+12 SET DGMTACT=$SELECT(DGMTI:"EDT",1:"ADD")
+13 SET DGMTP=""
IF DGMTACT="EDT"
SET DGMTP=$GET(^DGMT(408.31,DGMTI,0))
+14 SET DFN=$PIECE(DGMT0,U,2)
+15 ; Add new entry to Annual Means Test file (#408.31) for LTC 4 test
+16 IF DGMTACT="ADD"
Begin DoDot:1
+17 SET X=+DGMT0
SET (DIC,DIK)="^DGMT(408.31,"
SET DIC(0)="L"
SET DLAYGO=408.31
+18 DO FILE^DICN
SET DGMTI=+Y
+19 ;*GTS - EAS*1*70
+20 SET DGCONVRT=$$VRCHKUP^DGMTU2(4,$PIECE(DGMT0,"^",19),+DGMT0,+DGMT0)
+21 SET DATA(2.11)=1
End DoDot:1
if DGMTI'>0
QUIT
+22 FOR I=.01,.02,.04,.05,.06,.11,.14,.15,.18,.23
SET DATA(I)=$PIECE(DGMT0,U,(I/.01))
+23 IF '$DATA(DGEXMPT)
SET DGEXMPT=$$THRES(DFN,$PIECE(DGMT0,U,1))
+24 SET DATA(.03)=$SELECT(DGEXMPT:15,1:14)
SET DATA(.07)=DT
+25 SET DATA(.019)=4
SET DATA(2.02)=$PIECE(DGMT2,U,2)
SET DATA(2.08)=DGMT
+26 SET DATA(2.05)=$PIECE(DGMT2,U,5)
+27 IF $$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
+28 KILL DATA,ERROR
+29 ; Update the LTC copay test (type 3), if status changed
+30 IF DGMTACT="EDT"
DO UPLTC3(DGMTI)
+31 ; Update Audit file and IVM Patient file
+32 SET DGMTYPT=4
SET DGMTINF=1
DO AFTER^DGMTEVT
+33 DO EN^DGMTAUD
+34 DO EN^IVMPMTE
+35 QUIT
+36 ;
ASK(TYPE) ; Does user want to perform MT/LTC4 test now?
+1 ; Input - TYPE = Type of test, 1: MT; 4: LTC Copay Exemption
+2 ; Output - Y = 1 (YES)
+3 ; = 0 (NO)
+4 NEW DIR,TST
+5 SET TST=$SELECT(TYPE=1:"Means Test",1:"LTC Copay Exemption Test")
+6 WRITE !!,"The previous year's financial information is not on file for this veteran.",!,"A ",TST," is required."
+7 SET DIR("A")="Do you wish to complete the "_TST_" at this time"
+8 SET DIR("B")="NO"
SET DIR(0)="Y"
+9 WRITE !
DO ^DIR
+10 QUIT +(Y)
+11 ;
GETLTC4(DFN,DGMTDT) ; Return last LTC co-pay exemption test (type 4),
+1 ; if less than a year old
+2 ; Input - DFN = Patient IEN
+3 ; DGMTDT (optional) = Date of test
+4 ; Output - Y = Annual Means Test IEN^Date of Test^Status Name^
+5 ; Status Code^Source of Test
+6 ; = "" (no current LTC co-pay exemption test)
+7 NEW Y
+8 SET Y=""
if '$GET(DFN)
QUIT Y
IF '$GET(DGMTDT)
SET DGMTDT=DT
+9 SET Y=$$LST^DGMTU(DFN,DGMTDT,4)
IF '(+Y)
QUIT Y
+10 IF $$OLD^DGMTU4($PIECE(Y,U,2))
SET Y=""
+11 QUIT Y
+12 ;
DEL ;Delete incomplete LTC Copay Exemption test (type 4)
+1 ; Input -- DGMTI LTC Copay Exemption test IEN
+2 NEW DA,DIK,DIE,DR,V
+3 if '$GET(DGMTI)
QUIT
if $PIECE($GET(^DGMT(408.31,DGMTI,0)),U,19)'=4
QUIT
+4 ; Delete pointer in Income Relation file (#408.22)
+5 IF $DATA(^DGMT(408.22,"AMT",DGMTI))
Begin DoDot:1
+6 SET DIE="^DGMT(408.22,"
SET DR="31///@"
+7 SET V=$ORDER(^DGMT(408.22,"AMT",DGMTI,0))
if 'V
QUIT
+8 SET IR=0
FOR
SET IR=$ORDER(^DGMT(408.22,"AMT",DGMTI,V,IR))
if 'IR
QUIT
SET DA=$ORDER(^(IR,0))
IF DA
DO ^DIE
End DoDot:1
+9 ; Delete LTC Copay Exemption test from Annual Means Test file (#408.31)
+10 SET DA=DGMTI
SET DIK="^DGMT(408.31,"
+11 DO ^DIK
+12 QUIT
+13 ;
UPLTC3(DGMT4) ;If the status of a LTC Copay Exemption test (type 4) changes,
+1 ;update the status of the LTC Copay test (type 3), if necessary
+2 ; Input -- DGMT4 LTC Copay Exemption test IEN
+3 NEW DGMT3,DGMTS4,DGMTS3,DGS,DATA,ERROR
+4 if 'DGMT4
QUIT
+5 SET DGMT3=$ORDER(^DGMT(408.31,"AT",DGMT4,0))
if $GET(^DGMT(408.31,+DGMT3,0))=""
QUIT
+6 ; Get test status
+7 SET DGMTS4=$$GETNAME^DGMTH($PIECE(^DGMT(408.31,DGMT4,0),U,3))
+8 SET DGMTS3=$$GETNAME^DGMTH($PIECE(^DGMT(408.31,DGMT3,0),U,3))
+9 ; If test status is the same quit
+10 IF DGMTS4=DGMTS3
QUIT
+11 ; If LTC copay test (type 3) is Exempt and the Reason for Exemption is
+12 ; anything other than 2 (Income Last Year Below Threshold), quit
+13 IF DGMTS3="EXEMPT"
IF $PIECE($GET(^DGMT(408.31,DGMT3,2)),U,7)'=2
QUIT
+14 ; Get IEN of Means Test Status and update LTC copay test
+15 SET DGS=""
FOR
SET DGS=$ORDER(^DG(408.32,"B",DGMTS4,DGS))
if 'DGS
QUIT
IF $PIECE(^DG(408.32,DGS,0),U,19)=3
QUIT
+16 SET DATA(.03)=DGS
SET DATA(2.07)=$SELECT(DGMTS4="EXEMPT":2,1:"@")
+17 IF $$UPD^DGENDBS(408.31,DGMT3,.DATA,.ERROR)
+18 QUIT
