EASUM5.m

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 ---EASUM5   4087     printed  Feb 18, 2025@23:22:11                                                                                                                                                                                                      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