DG53296D.m

DG53296D ;JAT DG*5.3*296 DELETE DCD INCOME TESTS ; 01 JUNE 2000

 ;;5.3;REGISTRATION;**296,1015**;JUNE 1 2000;Build 21

 ;

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

 ;version of IVMCMD1 called DG53296C which only deletes the

 ;records from the Annual Means Test(#408.31) file.  It does not open

 ;a case record in the IVM Patient (#301.5)file, does not send 'delete'

 ;bulletin/notification to local mail group, does not call the means

 ;test event driver and does not call DGMTR.

 ;

EN(IVMMTIEN) ; --

 ; This routine will process income test deletion requests received

 ; from the IVM Center.

 ;

 ;  Input(s):

 ;       IVMMTIEN - pointer to test to be deleted in file 408.31

 ;

 ; Output(s):

 ;       Function Value - 1 test deleted

 ;                        0 test not deleted

 ;

 ;

 ; Initialize variables

 N DFN,IVMERR,IVMLINK,IVMNODE0,IVMDOT,IVMTOT,IVMDONE

 S IVMDONE=0

 ;

EN1 ; Get zero node of (#408.31)

 S IVMNODE0=$G(^DGMT(408.31,IVMMTIEN,0))

 I 'IVMNODE0 Q 1  ; test not found

 S IVMDOT=$P(IVMNODE0,"^") ; date of test

 S DFN=$P(IVMNODE0,"^",2)

 S IVMTOT=$P(IVMNODE0,"^",19) ; type of test

 S IVMLINK=$P($G(^DGMT(408.31,IVMMTIEN,2)),"^",6)

 I IVMTOT=2,IVMLINK Q 0  ; don't delete copay test linked to means test

 I IVMTOT=1,IVMLINK D  I $D(IVMERR) Q 0  ;I MT linkd to copay delete both

 .D DELETE(IVMLINK,DFN,IVMDOT) ; delete copay

 D DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT

 Q IVMDONE

 ;

DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT

 ;

 ; Get Income Relation IEN array (DGINR) and

 ; Individual Annual Income IEN array (DGINC)

 D ALL^DGMTU21(DFN,"VSC",IVMDOT,"IR",IVMMTIEN)

 ;

 ;

DEL22 ; Delete veteran, spouse, and dependent entries from the

 ; Income Relation (#408.22) file:

 ; - Veteran (#408.22) record

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

 .Q:'DA

 .S DIK="^DGMT(408.22,"

 .D ^DIK

 ;

 ; - Spouse (#408.22) record

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

 .Q:'DA

 .S DIK="^DGMT(408.22,"

 .D ^DIK

 ;

 ; - All dependent children (#408.22) records

 S IVMDEP=0

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

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

 .S DIK="^DGMT(408.22,"

 .D ^DIK

 ;

 ;

DEL21 ; Delete veteran, spouse, and dependent entries from

 ; Individual Annual Income (#408.21) file:

 ; - Veteran (#408.21) record

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

 .Q:'DA

 .S DIK="^DGMT(408.21,"

 .D ^DIK

 ;

 ; - Spouse (#408.21) record

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

 .Q:'DA

 .S DIK="^DGMT(408.21,"

 .D ^DIK

 ;

 ; - All dependent children (#408.21) records

 S IVMDEP=0

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

 .S DA=$G(DGINC("C",IVMDEP))

 .S DIK="^DGMT(408.21,"

 .D ^DIK

 ;

 ;

 ; Logic for (#408.12/#408.1275) & (#408.13) file entries

 D SETUPAR

 ;

 ; Look for IVM/DCD Patient Realtion (#408.12) file entries.

 ; If no entries in "AIVM" x-ref, no dependent changes required.

 S IVM12="" F  S IVM12=$O(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12)) Q:'IVM12  D  Q:$D(IVMERR)

 .; -- if can't find entry in (#408.12), set IVMERR

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

 ..S IVMERR="" Q

 .;

 .; - if only one record exists in (#408.1275) mult., then only one

 .;IVM/DCD dependent to delete

 .I $P($G(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1 D  Q

 ..;

 ..; -- if can't find entry in (#408.13), set IVMERR

 ..S IVM13=$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";")

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

 ...S IVMERR="" Q

 ..;

 ..; -- delete (#408.12) & (#408.13) records for IVM/DCD dependent

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

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

 ..Q

 .;

 .;

 .; Delete (#408.1275) record for IVM/DCD dependent and

 .; change demo data in (#408.12) & (#408.13) back to VAMC values.

 .; OR, Delete (#408.1275) record for inactivated VAMC dependent.

 .S IVM121="",IVM121=$O(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))

 .; - if can't find entry in (#408.1275), set IVMERR

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

 ..S IVMERR="" Q

 .;

 .S IVMVAMCA=$P($G(^DGPR(408.12,+IVM12,"E",+IVM121,0)),"^",2)

 .;dependent active?

 .;

 .; - If active, inactivate dependant

 .I IVMVAMCA D

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

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

 ..D ^DIE S IVMVAMCA=0 Q

 .;

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

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

 .;

 .Q

 ;

 ; Complete deletion of income test

 D EN^DG53296C

 ;

ENQ Q

 ;

 ;

SETUPAR ; Create array IVMAR1() 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 IVM41=4:1 S IVM411=$P($T(TYPECH+IVM41),";;",2) Q:IVM411="QUIT"  D

 .S IVMAR1($P(IVM411,";"))=$P(IVM411,";",2,3)

 K IVM41,IVM411

 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 MTNODE,YEAR,RET

 S YEAR=$E(MTDATE,1,3)_1230.999999

 D

 .S MTNODE=$$LST^DGMTU(DFN,YEAR,TYPE)

 .Q:'+MTNODE

 .I $E($P(MTNODE,"^",2),1,3)'=$E(YEAR,1,3) Q

 .;don't want to delete auto-created Rx copay tests -they are deleted by

 .; deleting the MT that they are based on

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

 .I $P(MTNODE,"^",5),$P(MTNODE,"^",5)'=1 I $$EN(+MTNODE) D

 ..;

 ..S RET=$$LST^DGMTU(DFN,DT,IVMTYPE)

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

 ..D ADD^IVMCMB(DFN,IVMTYPE,"DELETE PRMYTEST",$P(MTNODE,"^",2),$P(MTNODE,"^",4),$P(RET,"^",4))

 Q

 ;

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

 ;    1st piece - 408.42 table file node

 ;    2nd piece - file (408.12/408.13)

 ;    3rd piece - 408.12/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

DG53296D  ;JAT DG*5.3*296 DELETE DCD INCOME TESTS ; 01 JUNE 2000

 +1       ;;5.3;REGISTRATION;**296,1015**;JUNE 1 2000;Build 21

 +2       ;

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

 +4       ;version of IVMCMD1 called DG53296C which only deletes the

 +5       ;records from the Annual Means Test(#408.31) file.  It does not open

 +6       ;a case record in the IVM Patient (#301.5)file, does not send 'delete'

 +7       ;bulletin/notification to local mail group, does not call the means

 +8       ;test event driver and does not call DGMTR.

 +9       ;

EN(IVMMTIEN) ; --

 +1       ; This routine will process income test deletion requests received

 +2       ; from the IVM Center.

 +3       ;

 +4       ;  Input(s):

 +5       ;       IVMMTIEN - pointer to test to be deleted in file 408.31

 +6       ;

 +7       ; Output(s):

 +8       ;       Function Value - 1 test deleted

 +9       ;                        0 test not deleted

 +10      ;

 +11      ;

 +12      ; Initialize variables

 +13       NEW DFN,IVMERR,IVMLINK,IVMNODE0,IVMDOT,IVMTOT,IVMDONE

 +14       SET IVMDONE=0

 +15      ;

EN1       ; Get zero node of (#408.31)

 +1        SET IVMNODE0=$GET(^DGMT(408.31,IVMMTIEN,0))

 +2       ; test not found

           IF 'IVMNODE0

               QUIT 1

 +3       ; date of test

           SET IVMDOT=$PIECE(IVMNODE0,"^")

 +4        SET DFN=$PIECE(IVMNODE0,"^",2)

 +5       ; type of test

           SET IVMTOT=$PIECE(IVMNODE0,"^",19)

 +6        SET IVMLINK=$PIECE($GET(^DGMT(408.31,IVMMTIEN,2)),"^",6)

 +7       ; don't delete copay test linked to means test

           IF IVMTOT=2

               IF IVMLINK

                   QUIT 0

 +8       ;I MT linkd to copay delete both

           IF IVMTOT=1

               IF IVMLINK

                   Begin DoDot:1

 +9       ; delete copay

                       DO DELETE(IVMLINK,DFN,IVMDOT)

                   End DoDot:1

                   IF $DATA(IVMERR)

                       QUIT 0

 +10      ; delete copay or MT

           DO DELETE(IVMMTIEN,DFN,IVMDOT)

 +11       QUIT IVMDONE

 +12      ;

DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT

 +1       ;

 +2       ; Get Income Relation IEN array (DGINR) and

 +3       ; Individual Annual Income IEN array (DGINC)

 +4        DO ALL^DGMTU21(DFN,"VSC",IVMDOT,"IR",IVMMTIEN)

 +5       ;

 +6       ;

DEL22     ; Delete veteran, spouse, and dependent entries from the

 +1       ; Income Relation (#408.22) file:

 +2       ; - Veteran (#408.22) record

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

           Begin DoDot:1

 +4            IF 'DA

                   QUIT 

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

 +6            DO ^DIK

           End DoDot:1

 +7       ;

 +8       ; - Spouse (#408.22) record

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

           Begin DoDot:1

 +10           IF 'DA

                   QUIT 

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

 +12           DO ^DIK

           End DoDot:1

 +13      ;

 +14      ; - All dependent children (#408.22) records

 +15       SET IVMDEP=0

 +16       FOR 

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

               IF 'IVMDEP

                   QUIT 

               Begin DoDot:1

 +17               SET DA=$GET(DGINR("C",IVMDEP))

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

 +19               DO ^DIK

               End DoDot:1

 +20      ;

 +21      ;

DEL21     ; Delete veteran, spouse, and dependent entries from

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

 +2       ; - Veteran (#408.21) record

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

           Begin DoDot:1

 +4            IF 'DA

                   QUIT 

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

 +6            DO ^DIK

           End DoDot:1

 +7       ;

 +8       ; - Spouse (#408.21) record

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

           Begin DoDot:1

 +10           IF 'DA

                   QUIT 

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

 +12           DO ^DIK

           End DoDot:1

 +13      ;

 +14      ; - All dependent children (#408.21) records

 +15       SET IVMDEP=0

 +16       FOR 

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

               IF 'IVMDEP

                   QUIT 

               Begin DoDot:1

 +17               SET DA=$GET(DGINC("C",IVMDEP))

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

 +19               DO ^DIK

               End DoDot:1

 +20      ;

 +21      ;

 +22      ; Logic for (#408.12/#408.1275) & (#408.13) file entries

 +23       DO SETUPAR

 +24      ;

 +25      ; Look for IVM/DCD Patient Realtion (#408.12) file entries.

 +26      ; If no entries in "AIVM" x-ref, no dependent changes required.

 +27       SET IVM12=""

           FOR 

               SET IVM12=$ORDER(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12))

               IF 'IVM12

                   QUIT 

               Begin DoDot:1

 +28      ; -- if can't find entry in (#408.12), set IVMERR

 +29               IF $GET(^DGPR(408.12,+IVM12,0))']""

                       Begin DoDot:2

 +30                       SET IVMERR=""

                           QUIT 

                       End DoDot:2

                       QUIT 

 +31      ;

 +32      ; - if only one record exists in (#408.1275) mult., then only one

 +33      ;IVM/DCD dependent to delete

 +34               IF $PIECE($GET(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1

                       Begin DoDot:2

 +35      ;

 +36      ; -- if can't find entry in (#408.13), set IVMERR

 +37                       SET IVM13=$PIECE($PIECE($GET(^DGPR(408.12,+IVM12,0)),"^",3),";")

 +38                       IF $GET(^DGPR(408.13,+IVM13,0))']""

                               Begin DoDot:3

 +39                               SET IVMERR=""

                                   QUIT 

                               End DoDot:3

                               QUIT 

 +40      ;

 +41      ; -- delete (#408.12) & (#408.13) records for IVM/DCD dependent

 +42                       SET DA=IVM12

                           SET DIK="^DGPR(408.12,"

                           DO ^DIK

                           KILL DA,DIK

 +43                       SET DA=IVM13

                           SET DIK="^DGPR(408.13,"

                           DO ^DIK

                           KILL DA,DIK

 +44                       QUIT 

                       End DoDot:2

                       QUIT 

 +45      ;

 +46      ;

 +47      ; Delete (#408.1275) record for IVM/DCD dependent and

 +48      ; change demo data in (#408.12) & (#408.13) back to VAMC values.

 +49      ; OR, Delete (#408.1275) record for inactivated VAMC dependent.

 +50               SET IVM121=""

                   SET IVM121=$ORDER(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))

 +51      ; - if can't find entry in (#408.1275), set IVMERR

 +52               IF $GET(^DGPR(408.12,+IVM12,"E",+IVM121,0))']""

                       Begin DoDot:2

 +53                       SET IVMERR=""

                           QUIT 

                       End DoDot:2

                       QUIT 

 +54      ;

 +55               SET IVMVAMCA=$PIECE($GET(^DGPR(408.12,+IVM12,"E",+IVM121,0)),"^",2)

 +56      ;dependent active?

 +57      ;

 +58      ; - If active, inactivate dependant

 +59               IF IVMVAMCA

                       Begin DoDot:2

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

                           SET DA=+IVM121

                           SET DA(1)=0

 +61                       SET DIE="^DGPR(408.12,"_+IVM12_",""E"","

 +62                       DO ^DIE

                           SET IVMVAMCA=0

                           QUIT 

                       End DoDot:2

 +63      ;

 +64               SET DA(1)=IVM12

                   SET DA=IVM121

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

 +65               DO ^DIK

                   KILL DA(1),DA,DIK

 +66      ;

 +67               QUIT 

               End DoDot:1

               IF $DATA(IVMERR)

                   QUIT 

 +68      ;

 +69      ; Complete deletion of income test

 +70       DO EN^DG53296C

 +71      ;

ENQ        QUIT 

 +1       ;

 +2       ;

SETUPAR   ; Create array IVMAR1() where

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

 +2       ;     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 IVM41=4:1

               SET IVM411=$PIECE($TEXT(TYPECH+IVM41),";;",2)

               IF IVM411="QUIT"

                   QUIT 

               Begin DoDot:1

 +7                SET IVMAR1($PIECE(IVM411,";"))=$PIECE(IVM411,";",2,3)

               End DoDot:1

 +8        KILL IVM41,IVM411

 +9        QUIT 

 +10      ;

DELTYPE(DFN,MTDATE,TYPE) ;

 +1       ;will delete any primary test for patient=DFN for same income year as

 +2       ;MTDATE for test of type=TYPE

 +3       ;

 +4        IF '$GET(DFN)

               QUIT 

 +5        IF '$GET(MTDATE)

               QUIT 

 +6        IF '$GET(TYPE)

               QUIT 

 +7        NEW MTNODE,YEAR,RET

 +8        SET YEAR=$EXTRACT(MTDATE,1,3)_1230.999999

 +9        Begin DoDot:1

 +10           SET MTNODE=$$LST^DGMTU(DFN,YEAR,TYPE)

 +11           IF '+MTNODE

                   QUIT 

 +12           IF $EXTRACT($PIECE(MTNODE,"^",2),1,3)'=$EXTRACT(YEAR,1,3)

                   QUIT 

 +13      ;don't want to delete auto-created Rx copay tests -they are deleted by

 +14      ; deleting the MT that they are based on

 +15           IF TYPE=2

                   IF +$PIECE($GET(^DGMT(408.31,+MTNODE,2)),"^",6)

                       QUIT 

 +16           IF $PIECE(MTNODE,"^",5)

                   IF $PIECE(MTNODE,"^",5)'=1

                       IF $$EN(+MTNODE)

                           Begin DoDot:2

 +17      ;

 +18                           SET RET=$$LST^DGMTU(DFN,DT,IVMTYPE)

 +19                           IF $EXTRACT($PIECE(RET,"^",2),1,3)'=$EXTRACT(YEAR,1,3)

                                   SET RET=""

 +20                           DO ADD^IVMCMB(DFN,IVMTYPE,"DELETE PRMYTEST",$PIECE(MTNODE,"^",2),$PIECE(MTNODE,"^",4),$PIECE(RET,"^",4))

                           End DoDot:2

           End DoDot:1

 +21       QUIT 

 +22      ;

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

 +1       ;    1st piece - 408.42 table file node

 +2       ;    2nd piece - file (408.12/408.13)

 +3       ;    3rd piece - 408.12/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