Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: EASUM9

EASUM9.m

Go to the documentation of this file.
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