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 ---[H[J[2J[HEASUM8 4042 printed Dec 13, 2024@01:55:50 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
