EASUM9 ;ALB/BDB - DELETE IVM MEANS TEST ; 07/07/2006
;;1.0;ENROLLMENT APPLICATION SYSTEM;**111**;21-OCT-94;Build 59
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; This routine patterned after EASUM7.
;
EN ; this routine will process an IVM MT/CT delete request
; from the ESR.
;
; delete IVM MT/CT records in the following files:
; 408.22
; 408.21
;
; 408.12 & 408.13 if IVM dependent
; or
; 408.1275 if IVM & VAMC dependent (new 408.1275 record was
; created for each IVM dependent by upload).
; change back the following fields to VAMC values
; from IVM values:
; 408.12 - relationship
; 408.13 - name, dob, ssn, sex
; or
; 408.1275 if VAMC dependent (new inactivated 408.1275 record
; was created by upload).
;
; 408.31
;
; the "PRIM" node for the VAMC MT will be changed to 1
;
; the event driver will be called twice
; DGMTACT="DUP"
; DGMTACT="DEL"
;
;
; Input IVMMTDT MT date
; IVMMTIEN primary MT IEN
;
; check primary test is IVM
S IVMNO=$G(^DGMT(408.31,IVMMTIEN,0)) ; ivm mt 0th node
S IVMSOT=$P($G(^DG(408.34,+$P(IVMNO,"^",23),0)),"^") ; source of test
I IVMSOT'="IVM" D Q
.S HLERR="IVM "_^DG(408.33,DGMTYPT,0)_" for income year "_($E(DGLY,1,3)+1700)_" not found"
.D ACK^IVMPREC
;
; get VAMC MT/CT via AD xref (by type) to be re-instated ;EAS*1*42
S IVMVAMC="A" ; ivmvamc is vamc ien
; make sure you get the latest test of that type for that date first
F S IVMVAMC=$O(^DGMT(408.31,"AD",DGMTYPT,DFN,IVMMTDT,IVMVAMC),-1) Q:'IVMVAMC D Q:$D(IVMVNO)
. S IVMVNO=$G(^DGMT(408.31,+IVMVAMC,0)) ; vamc 0th node
. S IVMSOT=$P($G(^DG(408.34,+$P(IVMVNO,"^",23),0)),"^") ; source of test
. I IVMSOT'="VAMC",IVMSOT'="DCD",IVMSOT'="OTHER FACILITY" K IVMVNO Q
. Q
;
; check other dates for that income year EAS*1.0*111
I '$D(IVMVNO) D
.N IVMVAMCD S IVMVAMCD=IVMMTDT ;ivmvamcd is the mt/ct date to be reinstated
.F S IVMVAMCD=$O(^DGMT(408.31,"AD",DGMTYPT,DFN,IVMVAMCD),-1) Q:$E(IVMVAMCD,1,3)'=$E(IVMMTDT,1,3) D Q:$D(IVMVNO)
..S IVMVAMC="A" ; ivmvamc is vamc ien
..F S IVMVAMC=$O(^DGMT(408.31,"AD",DGMTYPT,DFN,IVMVAMCD,IVMVAMC),-1) Q:'IVMVAMC D Q:$D(IVMVNO)
...S IVMVNO=$G(^DGMT(408.31,+IVMVAMC,0)) ; vamc 0th node
...S IVMSOT=$P($G(^DG(408.34,+$P(IVMVNO,"^",23),0)),"^") ; source of test
...I IVMSOT'="VAMC",IVMSOT'="DCD",IVMSOT'="OTHER FACILITY" K IVMVNO Q
...Q
..Q
.Q
;
; if no previous VAMC RXCT (type 2) on file, then ;EAS*1*42
; simply delete the IVM RX converted 408.31 record
S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
I '$D(IVMVNO),DGMTYPT=2 D EN1^EASUM8 Q
;
; not an error if from esr EAS*1.0*111
;I '$D(IVMVNO) D Q
;.S HLERR=IVMSOT_^DG(408.33,DGMTYPT,0)_" for income year "_($E(DGLY,1,3)+1700)_" not found"
;.D ACK^IVMPREC
;
; get array dginc containing ien(s) of 408.21
; get array dginr containing ien(s) of 408.22
; IVMMTIEN IS THE IEN FOR THE IVM MT, HOWEVER IVMVAMC IS USING A DIFFERENT IEN AND IS THE ONE BEING REVERSED.
D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IR",IVMMTIEN)
;
; delete 408.22
;
S DA=$G(DGINR("V")) D
.Q:'DA S DIK="^DGMT(408.22," D ^DIK
S DA=$G(DGINR("S")) D
.Q:'DA S DIK="^DGMT(408.22," D ^DIK
S IVMN=0
F S IVMN=$O(DGINR("C",IVMN)) Q:'IVMN S DA=$G(DGINR("C",IVMN)),DIK="^DGMT(408.22," D ^DIK
;
; delete 408.21
;
S DA=$G(DGINC("V")) D
.Q:'DA S DIK="^DGMT(408.21," D ^DIK
S DA=$G(DGINC("S")) D
.Q:'DA S DIK="^DGMT(408.21," D ^DIK
S IVMN=0
F S IVMN=$O(DGINC("C",IVMN)) Q:'IVMN S DA=$G(DGINC("C",IVMN)),DIK="^DGMT(408.21," D ^DIK
;
; logic for 408.12/408.1275 & 408.13
;
D SETUPAR^EASUM8
;
; no "AIVM" x-ref means
; no dependents
; or
; IVM v2.0 means test (no dependent difference)
; only 408.22, 408.21, and 408.31 records will be deleted
;
S IVM12="" F S IVM12=$O(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12)) Q:'IVM12 D Q:$D(IVMFERR)
.I $G(^DGPR(408.12,+IVM12,0))']"" D Q
..S (IVMTEXT(6),HLERR)="Can't find 408.12 record "_IVM12
..D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
..S IVMFERR=""
..D ACK^IVMPREC
..Q
.;
.I $P($G(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1 D Q
..; only 1 multiple record (408.1275) indicates IVM dependent
..; delete 408.12 & 408.13 records for IVM dependent
..S IVM13=$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";") I $G(^DGPR(408.13,+IVM13,0))']"" D Q
...S (IVMTEXT(6),HLERR)="Can't find 408.13 record "_IVM13
...D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
...S IVMFERR=""
...D ACK^IVMPREC
...Q
..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 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))
.I $G(^DGPR(408.12,+IVM12,"E",+IVM121,0))']"" D Q
..S (IVMTEXT(6),HLERR)="Can't find 408.1275 record "_IVM12_" "_IVM121
..D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
..S IVMFERR=""
..D ACK^IVMPREC
..Q
.S IVMVAMCA=$P(^(0),"^",2) ; dependent active?
.S DA(1)=IVM12,DA=IVM121,DIK="^DGPR(408.12,"_DA(1)_",""E"","
.D ^DIK K DA(1),DA,DIK
.Q:'IVMVAMCA ; quit if inactivated VAMC dependent
.S IVM13=+$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";")
.D EN^EASUM8
.Q
;
Q:$D(IVMFERR)
D EN1^EASUM8
Q
;
ERRBULL ; build mail message for transmission to IVM mail group notifying site
; of upload error.
S IVMPAT=$$PT^IVMUFNC4(DFN)
S XMSUB="IVM - MEANS TEST UPLOAD"
S IVMTEXT(1)="The following error occurred when an Income Verification Match"
S IVMTEXT(2)="verified Means Test was being uploaded for the following patient:"
S IVMTEXT(3)=" "
S IVMTEXT(4)=" NAME: "_$P(IVMPAT,"^")
S IVMTEXT(5)=" ID: "_$P(IVMPAT,"^",2)
S IVMTEXT(6)=" ERROR: "_IVMTEXT(6)
Q
;
MTBULL ; build mail message for transmission to IVM mail group notifying them
; an IVM verified MT/CT has been uploaded into DHCP for a patient.
;
S IVMPAT=$$PT^IVMUFNC4(DFN)
S XMSUB="IVM - INCOME TEST UPLOAD for "_$P($P(IVMPAT,"^"),",")_" ("_$P(IVMPAT,"^",3)_")"
S IVMTEXT(1)="An Income Verification Match verified "
S IVMTEXT(1)=IVMTEXT(1)_^DG(408.33,DGMTYPT,0)_" has been uploaded"
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
;set previous sts from previous 408.31 or previous RX sts
S IVMTEXT(7)=" PREV CATEGORY: "
I DGMTYPT=2 D
. S IVMTEXT(7)=IVMTEXT(7)_IVMCEB
E D
. S IVMTEXT(7)=IVMTEXT(7)_$P($G(^DG(408.32,+$P(IVMMT31,"^",3),0)),"^",1)
;
S IVMTEXT(8)=" NEW CATEGORY: "_DGCAT
I IVM5 S Y=IVM5 X ^DD("DD") S IVMTEXT(9)=" DATE/TIME OF ADJUDICATION: "_Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASUM9 6818 printed Nov 22, 2024@17:05:59 Page 2
EASUM9 ;ALB/BDB - DELETE IVM MEANS TEST ; 07/07/2006
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**111**;21-OCT-94;Build 59
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; This routine patterned after EASUM7.
+5 ;
EN ; this routine will process an IVM MT/CT delete request
+1 ; from the ESR.
+2 ;
+3 ; delete IVM MT/CT records in the following files:
+4 ; 408.22
+5 ; 408.21
+6 ;
+7 ; 408.12 & 408.13 if IVM dependent
+8 ; or
+9 ; 408.1275 if IVM & VAMC dependent (new 408.1275 record was
+10 ; created for each IVM dependent by upload).
+11 ; change back the following fields to VAMC values
+12 ; from IVM values:
+13 ; 408.12 - relationship
+14 ; 408.13 - name, dob, ssn, sex
+15 ; or
+16 ; 408.1275 if VAMC dependent (new inactivated 408.1275 record
+17 ; was created by upload).
+18 ;
+19 ; 408.31
+20 ;
+21 ; the "PRIM" node for the VAMC MT will be changed to 1
+22 ;
+23 ; the event driver will be called twice
+24 ; DGMTACT="DUP"
+25 ; DGMTACT="DEL"
+26 ;
+27 ;
+28 ; Input IVMMTDT MT date
+29 ; IVMMTIEN primary MT IEN
+30 ;
+31 ; check primary test is IVM
+32 ; ivm mt 0th node
SET IVMNO=$GET(^DGMT(408.31,IVMMTIEN,0))
+33 ; source of test
SET IVMSOT=$PIECE($GET(^DG(408.34,+$PIECE(IVMNO,"^",23),0)),"^")
+34 IF IVMSOT'="IVM"
Begin DoDot:1
+35 SET HLERR="IVM "_^DG(408.33,DGMTYPT,0)_" for income year "_($EXTRACT(DGLY,1,3)+1700)_" not found"
+36 DO ACK^IVMPREC
End DoDot:1
QUIT
+37 ;
+38 ; get VAMC MT/CT via AD xref (by type) to be re-instated ;EAS*1*42
+39 ; ivmvamc is vamc ien
SET IVMVAMC="A"
+40 ; make sure you get the latest test of that type for that date first
+41 FOR
SET IVMVAMC=$ORDER(^DGMT(408.31,"AD",DGMTYPT,DFN,IVMMTDT,IVMVAMC),-1)
if 'IVMVAMC
QUIT
Begin DoDot:1
+42 ; vamc 0th node
SET IVMVNO=$GET(^DGMT(408.31,+IVMVAMC,0))
+43 ; source of test
SET IVMSOT=$PIECE($GET(^DG(408.34,+$PIECE(IVMVNO,"^",23),0)),"^")
+44 IF IVMSOT'="VAMC"
IF IVMSOT'="DCD"
IF IVMSOT'="OTHER FACILITY"
KILL IVMVNO
QUIT
+45 QUIT
End DoDot:1
if $DATA(IVMVNO)
QUIT
+46 ;
+47 ; check other dates for that income year EAS*1.0*111
+48 IF '$DATA(IVMVNO)
Begin DoDot:1
+49 ;ivmvamcd is the mt/ct date to be reinstated
NEW IVMVAMCD
SET IVMVAMCD=IVMMTDT
+50 FOR
SET IVMVAMCD=$ORDER(^DGMT(408.31,"AD",DGMTYPT,DFN,IVMVAMCD),-1)
if $EXTRACT(IVMVAMCD,1,3)'=$EXTRACT(IVMMTDT,1,3)
QUIT
Begin DoDot:2
+51 ; ivmvamc is vamc ien
SET IVMVAMC="A"
+52 FOR
SET IVMVAMC=$ORDER(^DGMT(408.31,"AD",DGMTYPT,DFN,IVMVAMCD,IVMVAMC),-1)
if 'IVMVAMC
QUIT
Begin DoDot:3
+53 ; vamc 0th node
SET IVMVNO=$GET(^DGMT(408.31,+IVMVAMC,0))
+54 ; source of test
SET IVMSOT=$PIECE($GET(^DG(408.34,+$PIECE(IVMVNO,"^",23),0)),"^")
+55 IF IVMSOT'="VAMC"
IF IVMSOT'="DCD"
IF IVMSOT'="OTHER FACILITY"
KILL IVMVNO
QUIT
+56 QUIT
End DoDot:3
if $DATA(IVMVNO)
QUIT
+57 QUIT
End DoDot:2
if $DATA(IVMVNO)
QUIT
+58 QUIT
End DoDot:1
+59 ;
+60 ; if no previous VAMC RXCT (type 2) on file, then ;EAS*1*42
+61 ; simply delete the IVM RX converted 408.31 record
+62 SET DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
+63 IF '$DATA(IVMVNO)
IF DGMTYPT=2
DO EN1^EASUM8
QUIT
+64 ;
+65 ; not an error if from esr EAS*1.0*111
+66 ;I '$D(IVMVNO) D Q
+67 ;.S HLERR=IVMSOT_^DG(408.33,DGMTYPT,0)_" for income year "_($E(DGLY,1,3)+1700)_" not found"
+68 ;.D ACK^IVMPREC
+69 ;
+70 ; get array dginc containing ien(s) of 408.21
+71 ; get array dginr containing ien(s) of 408.22
+72 ; IVMMTIEN IS THE IEN FOR THE IVM MT, HOWEVER IVMVAMC IS USING A DIFFERENT IEN AND IS THE ONE BEING REVERSED.
+73 DO ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IR",IVMMTIEN)
+74 ;
+75 ; delete 408.22
+76 ;
+77 SET DA=$GET(DGINR("V"))
Begin DoDot:1
+78 if 'DA
QUIT
SET DIK="^DGMT(408.22,"
DO ^DIK
End DoDot:1
+79 SET DA=$GET(DGINR("S"))
Begin DoDot:1
+80 if 'DA
QUIT
SET DIK="^DGMT(408.22,"
DO ^DIK
End DoDot:1
+81 SET IVMN=0
+82 FOR
SET IVMN=$ORDER(DGINR("C",IVMN))
if 'IVMN
QUIT
SET DA=$GET(DGINR("C",IVMN))
SET DIK="^DGMT(408.22,"
DO ^DIK
+83 ;
+84 ; delete 408.21
+85 ;
+86 SET DA=$GET(DGINC("V"))
Begin DoDot:1
+87 if 'DA
QUIT
SET DIK="^DGMT(408.21,"
DO ^DIK
End DoDot:1
+88 SET DA=$GET(DGINC("S"))
Begin DoDot:1
+89 if 'DA
QUIT
SET DIK="^DGMT(408.21,"
DO ^DIK
End DoDot:1
+90 SET IVMN=0
+91 FOR
SET IVMN=$ORDER(DGINC("C",IVMN))
if 'IVMN
QUIT
SET DA=$GET(DGINC("C",IVMN))
SET DIK="^DGMT(408.21,"
DO ^DIK
+92 ;
+93 ; logic for 408.12/408.1275 & 408.13
+94 ;
+95 DO SETUPAR^EASUM8
+96 ;
+97 ; no "AIVM" x-ref means
+98 ; no dependents
+99 ; or
+100 ; IVM v2.0 means test (no dependent difference)
+101 ; only 408.22, 408.21, and 408.31 records will be deleted
+102 ;
+103 SET IVM12=""
FOR
SET IVM12=$ORDER(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12))
if 'IVM12
QUIT
Begin DoDot:1
+104 IF $GET(^DGPR(408.12,+IVM12,0))']""
Begin DoDot:2
+105 SET (IVMTEXT(6),HLERR)="Can't find 408.12 record "_IVM12
+106 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC()
+107 SET IVMFERR=""
+108 DO ACK^IVMPREC
+109 QUIT
End DoDot:2
QUIT
+110 ;
+111 IF $PIECE($GET(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1
Begin DoDot:2
+112 ; only 1 multiple record (408.1275) indicates IVM dependent
+113 ; delete 408.12 & 408.13 records for IVM dependent
+114 SET IVM13=$PIECE($PIECE($GET(^DGPR(408.12,+IVM12,0)),"^",3),";")
IF $GET(^DGPR(408.13,+IVM13,0))']""
Begin DoDot:3
+115 SET (IVMTEXT(6),HLERR)="Can't find 408.13 record "_IVM13
+116 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC()
+117 SET IVMFERR=""
+118 DO ACK^IVMPREC
+119 QUIT
End DoDot:3
QUIT
+120 SET DA=IVM12
SET DIK="^DGPR(408.12,"
DO ^DIK
KILL DA,DIK
+121 SET DA=IVM13
SET DIK="^DGPR(408.13,"
DO ^DIK
KILL DA,DIK
+122 QUIT
End DoDot:2
QUIT
+123 ;
+124 ; delete 408.1275 record for IVM dependent and
+125 ; change demo data in 408.12 & 408.13 back to VAMC values
+126 ; or
+127 ; delete 408.1275 record for inactivated VAMC dependent
+128 SET IVM121=""
SET IVM121=$ORDER(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))
+129 IF $GET(^DGPR(408.12,+IVM12,"E",+IVM121,0))']""
Begin DoDot:2
+130 SET (IVMTEXT(6),HLERR)="Can't find 408.1275 record "_IVM12_" "_IVM121
+131 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC()
+132 SET IVMFERR=""
+133 DO ACK^IVMPREC
+134 QUIT
End DoDot:2
QUIT
+135 ; dependent active?
SET IVMVAMCA=$PIECE(^(0),"^",2)
+136 SET DA(1)=IVM12
SET DA=IVM121
SET DIK="^DGPR(408.12,"_DA(1)_",""E"","
+137 DO ^DIK
KILL DA(1),DA,DIK
+138 ; quit if inactivated VAMC dependent
if 'IVMVAMCA
QUIT
+139 SET IVM13=+$PIECE($PIECE($GET(^DGPR(408.12,+IVM12,0)),"^",3),";")
+140 DO EN^EASUM8
+141 QUIT
End DoDot:1
if $DATA(IVMFERR)
QUIT
+142 ;
+143 if $DATA(IVMFERR)
QUIT
+144 DO EN1^EASUM8
+145 QUIT
+146 ;
ERRBULL ; build mail message for transmission to IVM mail group notifying site
+1 ; of upload error.
+2 SET IVMPAT=$$PT^IVMUFNC4(DFN)
+3 SET XMSUB="IVM - MEANS TEST UPLOAD"
+4 SET IVMTEXT(1)="The following error occurred when an Income Verification Match"
+5 SET IVMTEXT(2)="verified Means Test was being uploaded for the following patient:"
+6 SET IVMTEXT(3)=" "
+7 SET IVMTEXT(4)=" NAME: "_$PIECE(IVMPAT,"^")
+8 SET IVMTEXT(5)=" ID: "_$PIECE(IVMPAT,"^",2)
+9 SET IVMTEXT(6)=" ERROR: "_IVMTEXT(6)
+10 QUIT
+11 ;
MTBULL ; build mail message for transmission to IVM mail group notifying them
+1 ; an IVM verified MT/CT has been uploaded into DHCP for a patient.
+2 ;
+3 SET IVMPAT=$$PT^IVMUFNC4(DFN)
+4 SET XMSUB="IVM - INCOME TEST UPLOAD for "_$PIECE($PIECE(IVMPAT,"^"),",")_" ("_$PIECE(IVMPAT,"^",3)_")"
+5 SET IVMTEXT(1)="An Income Verification Match verified "
+6 SET IVMTEXT(1)=IVMTEXT(1)_^DG(408.33,DGMTYPT,0)_" has been uploaded"
+7 SET IVMTEXT(2)="for the following patient:"
+8 SET IVMTEXT(3)=" "
+9 SET IVMTEXT(4)=" NAME: "_$PIECE(IVMPAT,"^")
+10 SET IVMTEXT(5)=" ID: "_$PIECE(IVMPAT,"^",2)
+11 SET Y=IVMMTDT
XECUTE ^DD("DD")
+12 SET IVMTEXT(6)=" DATE OF TEST: "_Y
+13 ;set previous sts from previous 408.31 or previous RX sts
+14 SET IVMTEXT(7)=" PREV CATEGORY: "
+15 IF DGMTYPT=2
Begin DoDot:1
+16 SET IVMTEXT(7)=IVMTEXT(7)_IVMCEB
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 SET IVMTEXT(7)=IVMTEXT(7)_$PIECE($GET(^DG(408.32,+$PIECE(IVMMT31,"^",3),0)),"^",1)
End DoDot:1
+19 ;
+20 SET IVMTEXT(8)=" NEW CATEGORY: "_DGCAT
+21 IF IVM5
SET Y=IVM5
XECUTE ^DD("DD")
SET IVMTEXT(9)=" DATE/TIME OF ADJUDICATION: "_Y
+22 QUIT
