EASUM8.m

EASUM8 ;ALB/GN - DELETE IVM MEANS TEST (CON'T) ; 6/16/04 1:09am

 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**42**;21-OCT-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 ;EAS*1*42 this routine patterned after IVMUM8

 ;         - add RX Copay Testing indentification to this routine.

 ;         - added language to the bulletin message specific to the

 ;           type of test being deleted.      type = 1 (Means Test)

 ;                                                 = 2 (RX Copay Test)

 ;

EN ; change demo data in 408.12 & 408.13 back to VAMC values

 ; ivm12     408.12 ien

 ; ivm13     408.13 ien

 ; ivmmtien  408.31 ien

 ;

 ; note: 408.13 fields were added to 408.41 before 408.12 field

 ;

 K DR S IVM41=0

 F  S IVM41=$O(^DGMT(408.41,"D",IVMMTIEN,IVM41)) Q:'IVM41  D

 .S IVM411=$G(^DGMT(408.41,+IVM41,0))

 .Q:$P(IVM411,"^",10)'=IVM13

 .S IVMOLD=$P(IVM411,"^",5)

 .S IVMOLD=$S(IVMOLD="":"@",1:IVMOLD)

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

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

 .I IVMFILE=408.13 S DA=IVM13,DIE="^DGPR(408.13,"

 .I IVMFILE=408.12 S DA=IVM12,DIE="^DGPR(408.12,"

 .S DR=IVMNOD_"////^S X=IVMOLD" D ^DIE K DA,DR,DIE

 .Q

 Q

 ;

EN1 ; change primary income test for year? code from 0 to 1 for VAMC MT

 I IVMVAMC D

 . S DA=IVMVAMC,DIE="^DGMT(408.31,",DR="2////1" D ^DIE K DA,DIE,DR

 ;

 ; Check link field, remove link before deleting record

 N LNKTEST S LNKTEST=$P($G(^DGMT(408.31,IVMMTIEN,2)),U,6)

 I LNKTEST S DA=LNKTEST,DIE="^DGMT(408.31,",DR="2.06////@" D ^DIE K DA,DIE,DR,LNKTEST

 ;

 ; delete 408.31

 S DA=IVMMTIEN,DIK="^DGMT(408.31," D ^DIK

 ;

 ; open IVM case record which was closed during upload

 S DA=$O(^IVM(301.5,"APT",+DFN,+DGLY,0))

 I $G(^IVM(301.5,+DA,0))']"" G MTBULL

 S DR=".04////0",DIE="^IVM(301.5," D ^DIE

 K ^IVM(301.5,DA,1)

 ;

MTBULL ; Build and transmit mail message to IVM mail group notifying site

 ; that an income test was deleted.  Run MT event driver or only IB

 ; event driver

 ;

 ;if deleting a previous IVM RXCT that had no previous VAMC 408.31,

 ;then only call IB event driver for the IB delete

 I '$D(IVMVNO) D

 . S DGMTACT="DEL"

 . D ^IBAMTED

 E  D

 . ; call event driver

 . S DGMTINF=1,DGMTP=IVMNO,DGMTA=IVMVNO

 . S DGMTACT="DUP",DGMTI=IVMVAMC D EN^DGMTEVT

 . S DGMTACT="DEL",DGMTI=IVMMTIEN D EN^DGMTEVT

 ;

 S IVMPAT=$$PT^IVMUFNC4(DFN)

 S XMSUB="IVM - INCOME TEST DELETED"

 S IVMTEXT(1)="An Income Verification Match "

 S IVMTEXT(1)=IVMTEXT(1)_^DG(408.33,DGMTYPT,0)_" was deleted"

 S IVMTEXT(2)="for the following patient:"

 S IVMTEXT(3)=" "

 S IVMTEXT(4)="    NAME:          "_$P(IVMPAT,"^")

 S IVMTEXT(5)="    ID:            "_$P(IVMPAT,"^",2)

 S Y=IVMMTDT X ^DD("DD")

 S IVMTEXT(6)="    DATE OF TEST:  "_Y

 S IVMTEXT(7)=" "

 S IVMTEXT(8)="NOTE:  The original DHCP "

 S IVMTEXT(8)=IVMTEXT(8)_^DG(408.33,DGMTYPT,0)_" is now primary"

 S IVMTEXT(9)=" "

 S IVMTEXT(10)="  PREV CATEGORY:  "_DGCAT

 ;

 S IVMTEXT(11)="   NEW CATEGORY:  "

 I DGMTYPT=2 D

 . S IVMTEXT(11)=IVMTEXT(11)_$P($$RXST^IBARXEU(DFN),"^",2)

 E  D

 . Q:'IVMVAMC

 . S IVMTEXT(11)=IVMTEXT(11)_$P($G(^DG(408.32,+$P(IVMVNO,"^",3),0)),"^",1)

 D MAIL^IVMUFNC()

 ;

 ; cleanup

 K DA,DFN,DGINC,DGINR,DGLY,DGMTA,DGMTACT,DGMTI,DGMTINF,DGMTP

 K DIE,DIK,DR,IVM12,IVM121,IVM13,IVM41,IVM411,IVMFILE

 K IVMFLGC,IVMMTDT,IVMMTIEN,IVMN,IVMNO,IVMNOD,IVMOLD

 K IVMPAT,IVMSOT,IVMTEXT,IVMVAMC,IVMVAMCA,IVMVNO,XMSUB,Y

 Q

 ;

SETUPAR ; create array ivmar1

 ; subscript is 408.42 node (type of change - name, dob, ssn, sex, relationship)

 ; 1st piece is file 408.12 or 408.13

 ; 2nd piece is 408.12 or 408.13 field #

 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

 ;

TYPECH ; type of dependent changes 408.41/408.42

 ; 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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---EASUM8   4042     printed  Feb 18, 2025@23:22:14                                                                                                                                                                                                      Page 2

EASUM8    ;ALB/GN - DELETE IVM MEANS TEST (CON'T) ; 6/16/04 1:09am

 +1       ;;1.0;ENROLLMENT APPLICATION SYSTEM;**42**;21-OCT-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;EAS*1*42 this routine patterned after IVMUM8

 +5       ;         - add RX Copay Testing indentification to this routine.

 +6       ;         - added language to the bulletin message specific to the

 +7       ;           type of test being deleted.      type = 1 (Means Test)

 +8       ;                                                 = 2 (RX Copay Test)

 +9       ;

EN        ; change demo data in 408.12 & 408.13 back to VAMC values

 +1       ; ivm12     408.12 ien

 +2       ; ivm13     408.13 ien

 +3       ; ivmmtien  408.31 ien

 +4       ;

 +5       ; note: 408.13 fields were added to 408.41 before 408.12 field

 +6       ;

 +7        KILL DR

           SET IVM41=0

 +8        FOR 

               SET IVM41=$ORDER(^DGMT(408.41,"D",IVMMTIEN,IVM41))

               if 'IVM41

                   QUIT 

               Begin DoDot:1

 +9                SET IVM411=$GET(^DGMT(408.41,+IVM41,0))

 +10               if $PIECE(IVM411,"^",10)'=IVM13

                       QUIT 

 +11               SET IVMOLD=$PIECE(IVM411,"^",5)

 +12               SET IVMOLD=$SELECT(IVMOLD="":"@",1:IVMOLD)

 +13               SET IVMFILE=$PIECE(IVMAR1($PIECE(IVM411,"^",2)),";")

 +14               SET IVMNOD=$PIECE(IVMAR1($PIECE(IVM411,"^",2)),";",2)

 +15               IF IVMFILE=408.13

                       SET DA=IVM13

                       SET DIE="^DGPR(408.13,"

 +16               IF IVMFILE=408.12

                       SET DA=IVM12

                       SET DIE="^DGPR(408.12,"

 +17               SET DR=IVMNOD_"////^S X=IVMOLD"

                   DO ^DIE

                   KILL DA,DR,DIE

 +18               QUIT 

               End DoDot:1

 +19       QUIT 

 +20      ;

EN1       ; change primary income test for year? code from 0 to 1 for VAMC MT

 +1        IF IVMVAMC

               Begin DoDot:1

 +2                SET DA=IVMVAMC

                   SET DIE="^DGMT(408.31,"

                   SET DR="2////1"

                   DO ^DIE

                   KILL DA,DIE,DR

               End DoDot:1

 +3       ;

 +4       ; Check link field, remove link before deleting record

 +5        NEW LNKTEST

           SET LNKTEST=$PIECE($GET(^DGMT(408.31,IVMMTIEN,2)),U,6)

 +6        IF LNKTEST

               SET DA=LNKTEST

               SET DIE="^DGMT(408.31,"

               SET DR="2.06////@"

               DO ^DIE

               KILL DA,DIE,DR,LNKTEST

 +7       ;

 +8       ; delete 408.31

 +9        SET DA=IVMMTIEN

           SET DIK="^DGMT(408.31,"

           DO ^DIK

 +10      ;

 +11      ; open IVM case record which was closed during upload

 +12       SET DA=$ORDER(^IVM(301.5,"APT",+DFN,+DGLY,0))

 +13       IF $GET(^IVM(301.5,+DA,0))']""

               GOTO MTBULL

 +14       SET DR=".04////0"

           SET DIE="^IVM(301.5,"

           DO ^DIE

 +15       KILL ^IVM(301.5,DA,1)

 +16      ;

MTBULL    ; Build and transmit mail message to IVM mail group notifying site

 +1       ; that an income test was deleted.  Run MT event driver or only IB

 +2       ; event driver

 +3       ;

 +4       ;if deleting a previous IVM RXCT that had no previous VAMC 408.31,

 +5       ;then only call IB event driver for the IB delete

 +6        IF '$DATA(IVMVNO)

               Begin DoDot:1

 +7                SET DGMTACT="DEL"

 +8                DO ^IBAMTED

               End DoDot:1

 +9       IF '$TEST

               Begin DoDot:1

 +10      ; call event driver

 +11               SET DGMTINF=1

                   SET DGMTP=IVMNO

                   SET DGMTA=IVMVNO

 +12               SET DGMTACT="DUP"

                   SET DGMTI=IVMVAMC

                   DO EN^DGMTEVT

 +13               SET DGMTACT="DEL"

                   SET DGMTI=IVMMTIEN

                   DO EN^DGMTEVT

               End DoDot:1

 +14      ;

 +15       SET IVMPAT=$$PT^IVMUFNC4(DFN)

 +16       SET XMSUB="IVM - INCOME TEST DELETED"

 +17       SET IVMTEXT(1)="An Income Verification Match "

 +18       SET IVMTEXT(1)=IVMTEXT(1)_^DG(408.33,DGMTYPT,0)_" was deleted"

 +19       SET IVMTEXT(2)="for the following patient:"

 +20       SET IVMTEXT(3)=" "

 +21       SET IVMTEXT(4)="    NAME:          "_$PIECE(IVMPAT,"^")

 +22       SET IVMTEXT(5)="    ID:            "_$PIECE(IVMPAT,"^",2)

 +23       SET Y=IVMMTDT

           XECUTE ^DD("DD")

 +24       SET IVMTEXT(6)="    DATE OF TEST:  "_Y

 +25       SET IVMTEXT(7)=" "

 +26       SET IVMTEXT(8)="NOTE:  The original DHCP "

 +27       SET IVMTEXT(8)=IVMTEXT(8)_^DG(408.33,DGMTYPT,0)_" is now primary"

 +28       SET IVMTEXT(9)=" "

 +29       SET IVMTEXT(10)="  PREV CATEGORY:  "_DGCAT

 +30      ;

 +31       SET IVMTEXT(11)="   NEW CATEGORY:  "

 +32       IF DGMTYPT=2

               Begin DoDot:1

 +33               SET IVMTEXT(11)=IVMTEXT(11)_$PIECE($$RXST^IBARXEU(DFN),"^",2)

               End DoDot:1

 +34      IF '$TEST

               Begin DoDot:1

 +35               if 'IVMVAMC

                       QUIT 

 +36               SET IVMTEXT(11)=IVMTEXT(11)_$PIECE($GET(^DG(408.32,+$PIECE(IVMVNO,"^",3),0)),"^",1)

               End DoDot:1

 +37       DO MAIL^IVMUFNC()

 +38      ;

 +39      ; cleanup

 +40       KILL DA,DFN,DGINC,DGINR,DGLY,DGMTA,DGMTACT,DGMTI,DGMTINF,DGMTP

 +41       KILL DIE,DIK,DR,IVM12,IVM121,IVM13,IVM41,IVM411,IVMFILE

 +42       KILL IVMFLGC,IVMMTDT,IVMMTIEN,IVMN,IVMNO,IVMNOD,IVMOLD

 +43       KILL IVMPAT,IVMSOT,IVMTEXT,IVMVAMC,IVMVAMCA,IVMVNO,XMSUB,Y

 +44       QUIT 

 +45      ;

SETUPAR   ; create array ivmar1

 +1       ; subscript is 408.42 node (type of change - name, dob, ssn, sex, relationship)

 +2       ; 1st piece is file 408.12 or 408.13

 +3       ; 2nd piece is 408.12 or 408.13 field #

 +4        FOR IVM41=4:1

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

               if IVM411="QUIT"

                   QUIT 

               Begin DoDot:1

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

               End DoDot:1

 +6        KILL IVM41,IVM411

 +7        QUIT 

 +8       ;

TYPECH    ; type of dependent changes 408.41/408.42

 +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