- 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 Jan 18, 2025@02:55:20 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