DG53426D.m

DG53426D ;ALB/AEG - DG*5.3*426 POST-INSTALLATION ;2-19-02

 ;;5.3;Registration;**426,1015**;2-19-02;Build 21

 ;

 ; This routine is a modified version of IVMCMD in that it calls a

 ; modified version of IVMCMD1 called DG53426E which only deletes the

 ; records from the ANNUAL MEANS TEST file (#408.31).  It does NOT 

 ; send a 'delete' bulletin/notification to the local mail group. It

 ; will create a case record in the IVM Patient file (#301.5) and it

 ; does call the means test event driver and will call the post-install

 ; version of DGMTR.

 ;

EN(MTIEN) ;

 ; This line tage will process an income test deletion request from 

 ; the post-installation portion of patch DG*5.3*426.

 ;

 ; Input - MTIEN = IEN of REQUIRED test to be deleted in file 408.31.

 ;

 ; Output(s):

 ;       Function Value: - 1 test deleted successfully.

 ;                         0 test not deleted.

 ;

 ; init variables

 N DFN,DGERR,DGLINK,DGNODE0,DGDOT,DGTOT,DGDONE

 S DGDONE=0

 ;

EN1 ; Get zeroth node of file 408.31 entry.

 S DGNODE0=$G(^DGMT(408.31,MTIEN,0))

 I 'DGNODE0 Q 1

 S DGDOT=$P($G(DGNODE0),U,1),DGTOT=$P($G(DGNODE0),U,19)

 S DFN=$P($G(DGNODE0),U,2),DGLINK=$P($G(^DGMT(408.31,MTIEN,2)),U,6)

 I DGTOT=2,DGLINK Q 0

 I DGTOT=1,DGLINK D  I $G(DGERR) Q 0

 .D DELETE(DGLINK,DFN,DGDOT) ; delete copay

 D DELETE(MTIEN,DFN,DGDOT)

 Q DGDONE

 ;

DELETE(MTIEN,DFN,DGDOT) ;delete a copay or MT

 ;

 ;Set DGMTP prior to deleting records

 S DGMTACT="DEL",DGMTI=MTIEN D PRIOR^DGMTEVT

 ; Individual annual Income array (DGINC)

 D ALL^DGMTU21(DFN,"VSC",DGDOT,"IR",MTIEN)

 ;

DEL22 ; Delete veteran, spouse, & dependent entries from the Income Relation

 ; (#408.22) file:

 ; 

 ; - Veteran #408.22 record IEN

 S DA=$G(DGINR("V")) D

 .Q:'DA

 .S DIK="^DGMT(408.22,"

 .L +^DGMT(408.22,DA):1

 .D ^DIK,IX1^DIK

 .L -^DGMT(408.22,DA)

 .K DA,DIK

 ;

 ; - Spouse 408.22 record

 S DA=$G(DGINR("S")) D

 .Q:'DA

 .S DIK="^DGMT(408.22,"

 .L +^DGMT(408.22,DA):1

 .D ^DIK,IX1^DIK

 .L -^DGMT(408.22,DA)

 .K DA,DIK

 ;

 ; - All Dependent Children entries in file 408.22

 S DGDEP=0

 F  S DGDEP=$O(DGINR("C",DGDEP)) Q:'DGDEP  D

 .S DA=$G(DGINR("C",DGDEP))

 .S DIK="^DGMT(408.22,"

 .L +^DGMT(408.22,DA):1

 .D ^DIK,IX1^DIK

 .K DA,DIK

 ;

DEL21 ; Delete veteran, spouse, & dependent children entries from the

 ; Individual Annual Income (#408.21) file:

 S DA=$G(DGINC("V")) D

 .Q:'DA

 .S DIK="^DGMT(408.21,"

 .L +^DGMT(408.21,DA):1

 .D ^DIK,IX1^DIK

 .L -^DGMT(408.21,DA)

 .K DA,DIK

 ;

 ; Spouse

 S DA=$G(DGINC("S")) D

 .Q:'DA

 .S DIK="^DGMT(408.21,"

 .L +^DGMT(408.21,DA):1

 .D ^DIK,IX1^DIK

 .L -^DGMT(408.21,DA)

 .K DA,DIK

 ;

 ; ALL Depn. Children 

 S DGDEP=0

 F  S DGDEP=$O(DGINC("C",DGDEP)) Q:'DGDEP  D

 .S DA=$G(DGINC("C",DGDEP)),DIK="^DGMT(408.21,"

 .L +^DGMT(408.21,DA):1

 .D ^DIK,IX1^DIK

 .L -^DGMT(408.21,DA)

 .K DA,DIK

 ;

 ; Logic for #408.12, #408.1275 & #408.13 file enties.

 D SETUPAR

 ;

 ; look for IVM Patient relation file entries.  If no entries in "AIVM"

 ; x-ref, no dependent changes are required.

 S DG12="" F  S DG12=$O(^DGPR(408.12,"AIVM",MTIEN,DG12)) Q:'DG12  D  Q:$D(DGERR)

 .; if any entry cannot be found in 408.12 set DGERR

 .I $G(^DGPR(408.12,+DG12,0))']"" D  Q

 ..S DGERR="" Q

 .;

 .; if only 1 record exists in the 408.1275 multiple then only 1 

 .; dependent to delete

 .I $P($G(^DGPR(408.13,+DG12,"E",0)),U,4)=1 D  Q

 ..;

 ..S DG13=$P($P($G(^DGPR(408.12,+DG12,0)),U,3),";")

 ..I $G(^DGPR(408.13,+DG13,0))']"" D  Q

 ...S DGERR="" Q

 ..;

 ..; Delete 408.12 & 408.13 records for dependent

 ..S DA=DG12,DIK="^DGPR(408.12," D ^DIK,IX1^DIK K DA,DIK

 ..S DA=DG13,DIK="^DGPR(408.13," D ^DIK,IX1^DIK K DA,DIK

 ..Q

 .;

 .; Delete #408.1275 multi. entry from dependent and change demo

 .; data in 408.12 & 408.13 back to VAMC values. OR delete 408.1275

 .; entry from inactivated VAMC dependent.

 .; if no entry found in multiple --- set DGERR

 .S DG121="",DG121=$O(^DGPR(408.12,"AIVM",MTIEN,+DG12,DG121))

 .; if no entry is found in multiple set DGERR

 .I $G(^DGPR(408.12,+DG12,"E",+DG121,0))']"" D  Q

 ..S DGERR="" Q

 .;

 .S DGVACMA=$P($G(^DGPR(408.12,+DG12,"E",+DG121,0)),U,2)

 .; Active depend?

 .I DGVACMA D

 ..S DR=".02////0",DA=+DG121,DA(1)=0

 ..S DIE="^DGPR(408.12,"_+DG12_",""E"","

 ..D ^DIE S DGVACMA=0 Q

 .;

 .S DA(1)=DG12,DA=DG121,DIK="^DGPR(408.12,"_DA(1)_",""E"","

 .D ^DIK K DA(1),DA,DIK

 .;

 .Q

 ;

 ; Complete the deletion of an income test.

 D EN^DG53426E

 ;

ENQ Q

 ;

 ;

SETUPAR ; Create data array DGMAR1() where

 ; 1 - Subscript is MT Changes Type (#408.42) file node where type

 ;     of change = Name, DOB, SSN, Sex, Relationship.

 ; 2 - 1st piece is #408.12 or #408.13 file.

 ; 3 - 2nd piece is #408.12 or #408.13 file field number.

 ;

 F DG41=4:1 S DG411=$P($T(TYPECH+DG41),";;",2) Q:DG411="QUIT"  D

 .S DGMAR($P(DG411,";"))=$P(DG411,";",2,3)

 K DG41,DG411

 Q

DELTYPE(DFN,MTDATE,TYPE) ;

 ; Will delete any primary test for patient (DFN) for same income

 ; year as MTDATE for test of type = TYPE

 ;

 Q:'$G(DFN)

 Q:'$G(MTDATE)

 Q:'$G(TYPE)

 N DGNODE,DGYEAR,RET

 S DGYEAR=$E(MTDATE,1,3)_1230.99999

 D

 .S DGNODE=$$LST^DGMTU(DGDFN,DGYEAR,TYPE)

 .Q:'+DGNODE

 .I $E($P(DGNODE,U,2),1,3)'=$E(YEAR,1,3) Q

 .; Don't delete auto created Rx copay tests - they are deleted

 .; by deleting the MT that they are linked to.

 .I TYPE=2,+$P($G(^DGMT(408.31,+DGNODE,2)),U,6) Q

 .I $P(DGNODE,U,5),$P(DGNODE,U,5)'=1 I $$EN(+MTNODE) D

 ..S RET=$$LST^DGMTU(DGDFN,DT,DGTYPE)

 ..I $E($P(RET,U,2),1,3)'=$E(YEAR,1,3) S RET=""

 ..D ADD^IVMCMB(DGDFN,DGTYPE,"DELETE PRMYTEST",$P(DGNODE,U,2),$P(DGNODE,U,4),$P(RET,U,4))

 Q

 ;

TYPECH ; Type of dependent change (#408.41/#408.42) file

 ;     1st piece - 408.42 table file node

 ;     2nd piece - file (#408.12 or 408.13)

 ;     3rd piece - 408.12 or 408.13 field

 ;;16;408.13;.01

 ;;17;408.13;.03

 ;;18;408.13;.09

 ;;19;408.13;.02

 ;;20;408.12;.02

 ;;QUIT

 Q

DG53426D  ;ALB/AEG - DG*5.3*426 POST-INSTALLATION ;2-19-02

 +1       ;;5.3;Registration;**426,1015**;2-19-02;Build 21

 +2       ;

 +3       ; This routine is a modified version of IVMCMD in that it calls a

 +4       ; modified version of IVMCMD1 called DG53426E which only deletes the

 +5       ; records from the ANNUAL MEANS TEST file (#408.31).  It does NOT 

 +6       ; send a 'delete' bulletin/notification to the local mail group. It

 +7       ; will create a case record in the IVM Patient file (#301.5) and it

 +8       ; does call the means test event driver and will call the post-install

 +9       ; version of DGMTR.

 +10      ;

EN(MTIEN) ;

 +1       ; This line tage will process an income test deletion request from 

 +2       ; the post-installation portion of patch DG*5.3*426.

 +3       ;

 +4       ; Input - MTIEN = IEN of REQUIRED test to be deleted in file 408.31.

 +5       ;

 +6       ; Output(s):

 +7       ;       Function Value: - 1 test deleted successfully.

 +8       ;                         0 test not deleted.

 +9       ;

 +10      ; init variables

 +11       NEW DFN,DGERR,DGLINK,DGNODE0,DGDOT,DGTOT,DGDONE

 +12       SET DGDONE=0

 +13      ;

EN1       ; Get zeroth node of file 408.31 entry.

 +1        SET DGNODE0=$GET(^DGMT(408.31,MTIEN,0))

 +2        IF 'DGNODE0

               QUIT 1

 +3        SET DGDOT=$PIECE($GET(DGNODE0),U,1)

           SET DGTOT=$PIECE($GET(DGNODE0),U,19)

 +4        SET DFN=$PIECE($GET(DGNODE0),U,2)

           SET DGLINK=$PIECE($GET(^DGMT(408.31,MTIEN,2)),U,6)

 +5        IF DGTOT=2

               IF DGLINK

                   QUIT 0

 +6        IF DGTOT=1

               IF DGLINK

                   Begin DoDot:1

 +7       ; delete copay

                       DO DELETE(DGLINK,DFN,DGDOT)

                   End DoDot:1

                   IF $GET(DGERR)

                       QUIT 0

 +8        DO DELETE(MTIEN,DFN,DGDOT)

 +9        QUIT DGDONE

 +10      ;

DELETE(MTIEN,DFN,DGDOT) ;delete a copay or MT

 +1       ;

 +2       ;Set DGMTP prior to deleting records

 +3        SET DGMTACT="DEL"

           SET DGMTI=MTIEN

           DO PRIOR^DGMTEVT

 +4       ; Individual annual Income array (DGINC)

 +5        DO ALL^DGMTU21(DFN,"VSC",DGDOT,"IR",MTIEN)

 +6       ;

DEL22     ; Delete veteran, spouse, & dependent entries from the Income Relation

 +1       ; (#408.22) file:

 +2       ; 

 +3       ; - Veteran #408.22 record IEN

 +4        SET DA=$GET(DGINR("V"))

           Begin DoDot:1

 +5            IF 'DA

                   QUIT 

 +6            SET DIK="^DGMT(408.22,"

 +7            LOCK +^DGMT(408.22,DA):1

 +8            DO ^DIK

               DO IX1^DIK

 +9            LOCK -^DGMT(408.22,DA)

 +10           KILL DA,DIK

           End DoDot:1

 +11      ;

 +12      ; - Spouse 408.22 record

 +13       SET DA=$GET(DGINR("S"))

           Begin DoDot:1

 +14           IF 'DA

                   QUIT 

 +15           SET DIK="^DGMT(408.22,"

 +16           LOCK +^DGMT(408.22,DA):1

 +17           DO ^DIK

               DO IX1^DIK

 +18           LOCK -^DGMT(408.22,DA)

 +19           KILL DA,DIK

           End DoDot:1

 +20      ;

 +21      ; - All Dependent Children entries in file 408.22

 +22       SET DGDEP=0

 +23       FOR 

               SET DGDEP=$ORDER(DGINR("C",DGDEP))

               IF 'DGDEP

                   QUIT 

               Begin DoDot:1

 +24               SET DA=$GET(DGINR("C",DGDEP))

 +25               SET DIK="^DGMT(408.22,"

 +26               LOCK +^DGMT(408.22,DA):1

 +27               DO ^DIK

                   DO IX1^DIK

 +28               KILL DA,DIK

               End DoDot:1

 +29      ;

DEL21     ; Delete veteran, spouse, & dependent children entries from the

 +1       ; Individual Annual Income (#408.21) file:

 +2        SET DA=$GET(DGINC("V"))

           Begin DoDot:1

 +3            IF 'DA

                   QUIT 

 +4            SET DIK="^DGMT(408.21,"

 +5            LOCK +^DGMT(408.21,DA):1

 +6            DO ^DIK

               DO IX1^DIK

 +7            LOCK -^DGMT(408.21,DA)

 +8            KILL DA,DIK

           End DoDot:1

 +9       ;

 +10      ; Spouse

 +11       SET DA=$GET(DGINC("S"))

           Begin DoDot:1

 +12           IF 'DA

                   QUIT 

 +13           SET DIK="^DGMT(408.21,"

 +14           LOCK +^DGMT(408.21,DA):1

 +15           DO ^DIK

               DO IX1^DIK

 +16           LOCK -^DGMT(408.21,DA)

 +17           KILL DA,DIK

           End DoDot:1

 +18      ;

 +19      ; ALL Depn. Children 

 +20       SET DGDEP=0

 +21       FOR 

               SET DGDEP=$ORDER(DGINC("C",DGDEP))

               IF 'DGDEP

                   QUIT 

               Begin DoDot:1

 +22               SET DA=$GET(DGINC("C",DGDEP))

                   SET DIK="^DGMT(408.21,"

 +23               LOCK +^DGMT(408.21,DA):1

 +24               DO ^DIK

                   DO IX1^DIK

 +25               LOCK -^DGMT(408.21,DA)

 +26               KILL DA,DIK

               End DoDot:1

 +27      ;

 +28      ; Logic for #408.12, #408.1275 & #408.13 file enties.

 +29       DO SETUPAR

 +30      ;

 +31      ; look for IVM Patient relation file entries.  If no entries in "AIVM"

 +32      ; x-ref, no dependent changes are required.

 +33       SET DG12=""

           FOR 

               SET DG12=$ORDER(^DGPR(408.12,"AIVM",MTIEN,DG12))

               IF 'DG12

                   QUIT 

               Begin DoDot:1

 +34      ; if any entry cannot be found in 408.12 set DGERR

 +35               IF $GET(^DGPR(408.12,+DG12,0))']""

                       Begin DoDot:2

 +36                       SET DGERR=""

                           QUIT 

                       End DoDot:2

                       QUIT 

 +37      ;

 +38      ; if only 1 record exists in the 408.1275 multiple then only 1 

 +39      ; dependent to delete

 +40               IF $PIECE($GET(^DGPR(408.13,+DG12,"E",0)),U,4)=1

                       Begin DoDot:2

 +41      ;

 +42                       SET DG13=$PIECE($PIECE($GET(^DGPR(408.12,+DG12,0)),U,3),";")

 +43                       IF $GET(^DGPR(408.13,+DG13,0))']""

                               Begin DoDot:3

 +44                               SET DGERR=""

                                   QUIT 

                               End DoDot:3

                               QUIT 

 +45      ;

 +46      ; Delete 408.12 & 408.13 records for dependent

 +47                       SET DA=DG12

                           SET DIK="^DGPR(408.12,"

                           DO ^DIK

                           DO IX1^DIK

                           KILL DA,DIK

 +48                       SET DA=DG13

                           SET DIK="^DGPR(408.13,"

                           DO ^DIK

                           DO IX1^DIK

                           KILL DA,DIK

 +49                       QUIT 

                       End DoDot:2

                       QUIT 

 +50      ;

 +51      ; Delete #408.1275 multi. entry from dependent and change demo

 +52      ; data in 408.12 & 408.13 back to VAMC values. OR delete 408.1275

 +53      ; entry from inactivated VAMC dependent.

 +54      ; if no entry found in multiple --- set DGERR

 +55               SET DG121=""

                   SET DG121=$ORDER(^DGPR(408.12,"AIVM",MTIEN,+DG12,DG121))

 +56      ; if no entry is found in multiple set DGERR

 +57               IF $GET(^DGPR(408.12,+DG12,"E",+DG121,0))']""

                       Begin DoDot:2

 +58                       SET DGERR=""

                           QUIT 

                       End DoDot:2

                       QUIT 

 +59      ;

 +60               SET DGVACMA=$PIECE($GET(^DGPR(408.12,+DG12,"E",+DG121,0)),U,2)

 +61      ; Active depend?

 +62               IF DGVACMA

                       Begin DoDot:2

 +63                       SET DR=".02////0"

                           SET DA=+DG121

                           SET DA(1)=0

 +64                       SET DIE="^DGPR(408.12,"_+DG12_",""E"","

 +65                       DO ^DIE

                           SET DGVACMA=0

                           QUIT 

                       End DoDot:2

 +66      ;

 +67               SET DA(1)=DG12

                   SET DA=DG121

                   SET DIK="^DGPR(408.12,"_DA(1)_",""E"","

 +68               DO ^DIK

                   KILL DA(1),DA,DIK

 +69      ;

 +70               QUIT 

               End DoDot:1

               IF $DATA(DGERR)

                   QUIT 

 +71      ;

 +72      ; Complete the deletion of an income test.

 +73       DO EN^DG53426E

 +74      ;

ENQ        QUIT 

 +1       ;

 +2       ;

SETUPAR   ; Create data array DGMAR1() where

 +1       ; 1 - Subscript is MT Changes Type (#408.42) file node where type

 +2       ;     of change = Name, DOB, SSN, Sex, Relationship.

 +3       ; 2 - 1st piece is #408.12 or #408.13 file.

 +4       ; 3 - 2nd piece is #408.12 or #408.13 file field number.

 +5       ;

 +6        FOR DG41=4:1

               SET DG411=$PIECE($TEXT(TYPECH+DG41),";;",2)

               IF DG411="QUIT"

                   QUIT 

               Begin DoDot:1

 +7                SET DGMAR($PIECE(DG411,";"))=$PIECE(DG411,";",2,3)

               End DoDot:1

 +8        KILL DG41,DG411

 +9        QUIT 

DELTYPE(DFN,MTDATE,TYPE) ;

 +1       ; Will delete any primary test for patient (DFN) for same income

 +2       ; year as MTDATE for test of type = TYPE

 +3       ;

 +4        IF '$GET(DFN)

               QUIT 

 +5        IF '$GET(MTDATE)

               QUIT 

 +6        IF '$GET(TYPE)

               QUIT 

 +7        NEW DGNODE,DGYEAR,RET

 +8        SET DGYEAR=$EXTRACT(MTDATE,1,3)_1230.99999

 +9        Begin DoDot:1

 +10           SET DGNODE=$$LST^DGMTU(DGDFN,DGYEAR,TYPE)

 +11           IF '+DGNODE

                   QUIT 

 +12           IF $EXTRACT($PIECE(DGNODE,U,2),1,3)'=$EXTRACT(YEAR,1,3)

                   QUIT 

 +13      ; Don't delete auto created Rx copay tests - they are deleted

 +14      ; by deleting the MT that they are linked to.

 +15           IF TYPE=2

                   IF +$PIECE($GET(^DGMT(408.31,+DGNODE,2)),U,6)

                       QUIT 

 +16           IF $PIECE(DGNODE,U,5)

                   IF $PIECE(DGNODE,U,5)'=1

                       IF $$EN(+MTNODE)

                           Begin DoDot:2

 +17                           SET RET=$$LST^DGMTU(DGDFN,DT,DGTYPE)

 +18                           IF $EXTRACT($PIECE(RET,U,2),1,3)'=$EXTRACT(YEAR,1,3)

                                   SET RET=""

 +19                           DO ADD^IVMCMB(DGDFN,DGTYPE,"DELETE PRMYTEST",$PIECE(DGNODE,U,2),$PIECE(DGNODE,U,4),$PIECE(RET,U,4))

                           End DoDot:2

           End DoDot:1

 +20       QUIT 

 +21      ;

TYPECH    ; Type of dependent change (#408.41/#408.42) file

 +1       ;     1st piece - 408.42 table file node

 +2       ;     2nd piece - file (#408.12 or 408.13)

 +3       ;     3rd piece - 408.12 or 408.13 field

 +4       ;;16;408.13;.01

 +5       ;;17;408.13;.03

 +6       ;;18;408.13;.09

 +7       ;;19;408.13;.02

 +8       ;;20;408.12;.02

 +9       ;;QUIT

 +10       QUIT