EASUM5 ;ALB/SEK,MNH - ADD NEW INCOME RELATION FILE ENTRIES ;19 MAY 94 9:30am
;;1.0;ENROLLMENT APPLICATION SYSTEM;**113**;21-OCT-94 ;Build 53
;;Per VA Directive 6402, this routine should not be modified.
;
;CLONED FROM IVMUM5
;
EN ; this routine will add entries to INCOME RELATION file (408.22)
; will also inactivate VAMC dependents (spouse & children) who are not
; IVM dependents, by adding an inactivate entry into the EFFECTIVE DATE
; sub-file (multiple-408.1275) of the PATIENT RELATION file (#408.12)
;
; DFN Patient file IEN
; DGINI Individual Annual Income IEN
; DGIRI Income Relation IEN
; IVMSEG ZIR record for veteran or spouse or dependent
; IVM0 408.22 0 node pieces 5-7
; IVM01 0 node pieces 9-12
; IVM02 0 node piece 6
; IVM03 0 node piece 20 EAS*1*113
;
N IVM0,IVM01,IVM02,IVM03
S DGIRI=$$ADDIR^DGMTU2(DFN,DGINI)
;
; if can't create stub notify site & IVM Center
I DGIRI'>0 D Q
.S (IVMTEXT(6),HLERR)="Can't create stub for file 408.22"
.D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
.S IVMFERR=""
;
; set "mt" node to annual means test ien
D MT^DGMTSCU3(DGIRI,DGMTI)
Q:IVMSPCHV="S"
;
; set number of dependent children (#.13) and dependent children(#.08)
; in income relation file (#408.22) based on active child dependents
; in patient relation file (#408.12).
; make IVM means test primary income test for year
I IVMSPCHV="V" D Q:$D(IVMFERR)
.S DA=IVMMTIEN,DIE="^DGMT(408.31,",DR="2////0" D ^DIE ; vamc mt
.S DA=DGMTI,DIE="^DGMT(408.31,",DR="2////1" D ^DIE ; ivm mt
.;S DR=DR_"0////^S X=IVM03;21" ;EAS*1*113
.;
.; inactivate VAMC dependents who are not IVM dependents
.K DGREL("V")
.I $D(DGREL) D INACTIVE Q:$D(IVMFERR)
.;
.D RESET^DGMTU11(DFN,DGLY,DGMTI)
.I $P($G(^DGMT(408.22,DGIRI,0)),"^",8)="" D
..S DA=DGIRI,DR=".08////0;.13////@",DIE="^DGMT(408.22," D ^DIE
..K DA,DR,DIE
.S IVM0=$P(IVMSEG,"^",2,4)
I IVMSPCHV="C" S IVM01=$P(IVMSEG,"^",6,9),IVM02=$P(IVMSEG,"^",3),IVM02=$P(IVMSEG,"^",30),IVM03=$P(IVMSEG,"^",15) ; EAS*1*113
S DIK="^DGMT(408.22,"
L +^DGMT(408.22,DGIRI):5 S:IVMSPCHV="V" $P(^DGMT(408.22,DGIRI,0),"^",5,7)=IVM0 S:IVMSPCHV="C" $P(^DGMT(408.22,DGIRI,0),"^",9,12)=IVM01,$P(^(0),"^",6)=IVM02,$P(^(0),"^",20)=IVM03 S DA=DGIRI D IX1^DIK L -^DGMT(408.22,DGIRI) ;EAS*1*113
K DA,DIK
Q
;
INACTIVE ; inactivate dependents not in IVM means test and kill
; corresponding dgrel
I $D(DGREL("S")) S DA(1)=+DGREL("S") D K DGREL("S")
.D CHKINACT
.Q:IVMFLG6!($D(IVMFERR))
.; if spouse was active before income year, add record with date
.; of 12/31 of year before income year with active code 0
.S X=$E(DGLY,1,3)-1_1231
.D INACT1
Q:'$D(DGREL)!($D(IVMFERR))
S IVMACTR=0
F S IVMACTR=$O(DGREL("C",IVMACTR)) Q:'IVMACTR S DA(1)=+DGREL("C",IVMACTR) D K DGREL("C",IVMACTR)
.D CHKINACT
.Q:IVMFLG6!($D(IVMFERR))
.; if child was active before income year, add record with date
.; of 12/31 of year before income year with active code 0
.S X=$E(DGLY,1,3)-1_1231
.D INACT1
;
K IVMACTR,IVMDGLY,IVMFLG6,IVMYEAR
Q
;
CHKINACT ; if dependent was made active during income year
; add record for same date (add .08 time) with active code 0
;
S IVMFLG6=0
S IVMDGLY="" F S IVMDGLY=$O(^DGPR(408.12,DA(1),"E","B",IVMDGLY)) Q:IVMDGLY']"" D Q:IVMFLG6!($D(IVMFERR))
.Q:$E(IVMDGLY,1,3)'=$E(DGLY,1,3)
.S IVMYEAR=0 F S IVMYEAR=$O(^(IVMDGLY,IVMYEAR)) Q:IVMYEAR']"" D Q:IVMFLG6!($D(IVMFERR))
..I $P($G(^DGPR(408.12,DA(1),"E",IVMYEAR,0)),"^",2) D
...S X=IVMDGLY_.08 D INACT1 S IVMFLG6=1
...Q
Q
;
INACT1 ; add inactivate entry to 408.1275
;
K DINUM
S (DIK,DIC)="^DGPR(408.12,DA(1),""E"",",DIC(0)="L",DLAYGO=408.1275 K DD,DO D FILE^DICN S DA=+Y K DLAYGO
;
; if can't create stub notify site & IVM Center
I DA'>0 D Q
.S (IVMTEXT(6),HLERR)="Can't create stub for file 408.1275"
.D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
.S IVMFERR=""
L +^DGPR(408.12,+DGPRI):5 S $P(^DGPR(408.12,DA(1),"E",DA,0),"^",2,4)=0_"^"_1_"^"_DGMTI D IX1^DIK L -^DGPR(408.12,+DGPRI)
K DA,DIC,DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASUM5 4087 printed Sep 23, 2025@19:31:52 Page 2
EASUM5 ;ALB/SEK,MNH - ADD NEW INCOME RELATION FILE ENTRIES ;19 MAY 94 9:30am
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**113**;21-OCT-94 ;Build 53
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;CLONED FROM IVMUM5
+5 ;
EN ; this routine will add entries to INCOME RELATION file (408.22)
+1 ; will also inactivate VAMC dependents (spouse & children) who are not
+2 ; IVM dependents, by adding an inactivate entry into the EFFECTIVE DATE
+3 ; sub-file (multiple-408.1275) of the PATIENT RELATION file (#408.12)
+4 ;
+5 ; DFN Patient file IEN
+6 ; DGINI Individual Annual Income IEN
+7 ; DGIRI Income Relation IEN
+8 ; IVMSEG ZIR record for veteran or spouse or dependent
+9 ; IVM0 408.22 0 node pieces 5-7
+10 ; IVM01 0 node pieces 9-12
+11 ; IVM02 0 node piece 6
+12 ; IVM03 0 node piece 20 EAS*1*113
+13 ;
+14 NEW IVM0,IVM01,IVM02,IVM03
+15 SET DGIRI=$$ADDIR^DGMTU2(DFN,DGINI)
+16 ;
+17 ; if can't create stub notify site & IVM Center
+18 IF DGIRI'>0
Begin DoDot:1
+19 SET (IVMTEXT(6),HLERR)="Can't create stub for file 408.22"
+20 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC()
+21 SET IVMFERR=""
End DoDot:1
QUIT
+22 ;
+23 ; set "mt" node to annual means test ien
+24 DO MT^DGMTSCU3(DGIRI,DGMTI)
+25 if IVMSPCHV="S"
QUIT
+26 ;
+27 ; set number of dependent children (#.13) and dependent children(#.08)
+28 ; in income relation file (#408.22) based on active child dependents
+29 ; in patient relation file (#408.12).
+30 ; make IVM means test primary income test for year
+31 IF IVMSPCHV="V"
Begin DoDot:1
+32 ; vamc mt
SET DA=IVMMTIEN
SET DIE="^DGMT(408.31,"
SET DR="2////0"
DO ^DIE
+33 ; ivm mt
SET DA=DGMTI
SET DIE="^DGMT(408.31,"
SET DR="2////1"
DO ^DIE
+34 ;S DR=DR_"0////^S X=IVM03;21" ;EAS*1*113
+35 ;
+36 ; inactivate VAMC dependents who are not IVM dependents
+37 KILL DGREL("V")
+38 IF $DATA(DGREL)
DO INACTIVE
if $DATA(IVMFERR)
QUIT
+39 ;
+40 DO RESET^DGMTU11(DFN,DGLY,DGMTI)
+41 IF $PIECE($GET(^DGMT(408.22,DGIRI,0)),"^",8)=""
Begin DoDot:2
+42 SET DA=DGIRI
SET DR=".08////0;.13////@"
SET DIE="^DGMT(408.22,"
DO ^DIE
+43 KILL DA,DR,DIE
End DoDot:2
+44 SET IVM0=$PIECE(IVMSEG,"^",2,4)
End DoDot:1
if $DATA(IVMFERR)
QUIT
+45 ; EAS*1*113
IF IVMSPCHV="C"
SET IVM01=$PIECE(IVMSEG,"^",6,9)
SET IVM02=$PIECE(IVMSEG,"^",3)
SET IVM02=$PIECE(IVMSEG,"^",30)
SET IVM03=$PIECE(IVMSEG,"^",15)
+46 SET DIK="^DGMT(408.22,"
+47 ;EAS*1*113
LOCK +^DGMT(408.22,DGIRI):5
if IVMSPCHV="V"
SET $PIECE(^DGMT(408.22,DGIRI,0),"^",5,7)=IVM0
if IVMSPCHV="C"
SET $PIECE(^DGMT(408.22,DGIRI,0),"^",9,12)=IVM01
SET $PIECE(^(0),"^",6)=IVM02
SET $PIECE(^(0),"^",20)=IVM03
SET DA=DGIRI
DO IX1^DIK
LOCK -^DGMT(408.22,DGIRI)
+48 KILL DA,DIK
+49 QUIT
+50 ;
INACTIVE ; inactivate dependents not in IVM means test and kill
+1 ; corresponding dgrel
+2 IF $DATA(DGREL("S"))
SET DA(1)=+DGREL("S")
Begin DoDot:1
+3 DO CHKINACT
+4 if IVMFLG6!($DATA(IVMFERR))
QUIT
+5 ; if spouse was active before income year, add record with date
+6 ; of 12/31 of year before income year with active code 0
+7 SET X=$EXTRACT(DGLY,1,3)-1_1231
+8 DO INACT1
End DoDot:1
KILL DGREL("S")
+9 if '$DATA(DGREL)!($DATA(IVMFERR))
QUIT
+10 SET IVMACTR=0
+11 FOR
SET IVMACTR=$ORDER(DGREL("C",IVMACTR))
if 'IVMACTR
QUIT
SET DA(1)=+DGREL("C",IVMACTR)
Begin DoDot:1
+12 DO CHKINACT
+13 if IVMFLG6!($DATA(IVMFERR))
QUIT
+14 ; if child was active before income year, add record with date
+15 ; of 12/31 of year before income year with active code 0
+16 SET X=$EXTRACT(DGLY,1,3)-1_1231
+17 DO INACT1
End DoDot:1
KILL DGREL("C",IVMACTR)
+18 ;
+19 KILL IVMACTR,IVMDGLY,IVMFLG6,IVMYEAR
+20 QUIT
+21 ;
CHKINACT ; if dependent was made active during income year
+1 ; add record for same date (add .08 time) with active code 0
+2 ;
+3 SET IVMFLG6=0
+4 SET IVMDGLY=""
FOR
SET IVMDGLY=$ORDER(^DGPR(408.12,DA(1),"E","B",IVMDGLY))
if IVMDGLY']""
QUIT
Begin DoDot:1
+5 if $EXTRACT(IVMDGLY,1,3)'=$EXTRACT(DGLY,1,3)
QUIT
+6 SET IVMYEAR=0
FOR
SET IVMYEAR=$ORDER(^(IVMDGLY,IVMYEAR))
if IVMYEAR']""
QUIT
Begin DoDot:2
+7 IF $PIECE($GET(^DGPR(408.12,DA(1),"E",IVMYEAR,0)),"^",2)
Begin DoDot:3
+8 SET X=IVMDGLY_.08
DO INACT1
SET IVMFLG6=1
+9 QUIT
End DoDot:3
End DoDot:2
if IVMFLG6!($DATA(IVMFERR))
QUIT
End DoDot:1
if IVMFLG6!($DATA(IVMFERR))
QUIT
+10 QUIT
+11 ;
INACT1 ; add inactivate entry to 408.1275
+1 ;
+2 KILL DINUM
+3 SET (DIK,DIC)="^DGPR(408.12,DA(1),""E"","
SET DIC(0)="L"
SET DLAYGO=408.1275
KILL DD,DO
DO FILE^DICN
SET DA=+Y
KILL DLAYGO
+4 ;
+5 ; if can't create stub notify site & IVM Center
+6 IF DA'>0
Begin DoDot:1
+7 SET (IVMTEXT(6),HLERR)="Can't create stub for file 408.1275"
+8 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC()
+9 SET IVMFERR=""
End DoDot:1
QUIT
+10 LOCK +^DGPR(408.12,+DGPRI):5
SET $PIECE(^DGPR(408.12,DA(1),"E",DA,0),"^",2,4)=0_"^"_1_"^"_DGMTI
DO IX1^DIK
LOCK -^DGPR(408.12,+DGPRI)
+11 KILL DA,DIC,DIK
+12 QUIT
