- IVMUM7 ;ALB/SEK,RTK - DELETE IVM MEANS TEST ; 23 JUNE 00
- ;;2.0;INCOME VERIFICATION MATCH;**1,17,31**;21-OCT-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN ; this routine will process an IVM means test delete request
- ; from the IVM Center.
- ;
- ; delete IVM mean test 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 means test for income year "_($E(DGLY,1,3)+1700)_" not found"
- .D ACK^IVMPREC
- ;
- ; get VAMC mt
- S IVMVAMC=0 ; ivmvamc is vamc ien
- F S IVMVAMC=$O(^DGMT(408.31,"AD",1,DFN,IVMMTDT,IVMVAMC)) 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
- I '$D(IVMVNO) D Q
- .S HLERR=IVMSOT_" means test 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
- 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^IVMUM8
- ;
- ; 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^IVMUM8
- .Q
- ;
- Q:$D(IVMFERR)
- D EN1^IVMUM8
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMUM7 4368 printed Feb 18, 2025@23:28:35 Page 2
- IVMUM7 ;ALB/SEK,RTK - DELETE IVM MEANS TEST ; 23 JUNE 00
- +1 ;;2.0;INCOME VERIFICATION MATCH;**1,17,31**;21-OCT-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- EN ; this routine will process an IVM means test delete request
- +1 ; from the IVM Center.
- +2 ;
- +3 ; delete IVM mean test 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 means test for income year "_($EXTRACT(DGLY,1,3)+1700)_" not found"
- +36 DO ACK^IVMPREC
- End DoDot:1
- QUIT
- +37 ;
- +38 ; get VAMC mt
- +39 ; ivmvamc is vamc ien
- SET IVMVAMC=0
- +40 FOR
- SET IVMVAMC=$ORDER(^DGMT(408.31,"AD",1,DFN,IVMMTDT,IVMVAMC))
- if 'IVMVAMC
- QUIT
- Begin DoDot:1
- +41 ; vamc 0th node
- SET IVMVNO=$GET(^DGMT(408.31,+IVMVAMC,0))
- +42 ; source of test
- SET IVMSOT=$PIECE($GET(^DG(408.34,+$PIECE(IVMVNO,"^",23),0)),"^")
- +43 IF IVMSOT'="VAMC"
- IF IVMSOT'="DCD"
- IF IVMSOT'="OTHER FACILITY"
- KILL IVMVNO
- QUIT
- End DoDot:1
- if $DATA(IVMVNO)
- QUIT
- +44 IF '$DATA(IVMVNO)
- Begin DoDot:1
- +45 SET HLERR=IVMSOT_" means test for income year "_($EXTRACT(DGLY,1,3)+1700)_" not found"
- +46 DO ACK^IVMPREC
- End DoDot:1
- QUIT
- +47 ;
- +48 ; get array dginc containing ien(s) of 408.21
- +49 ; get array dginr containing ien(s) of 408.22
- +50 DO ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IR",IVMMTIEN)
- +51 ;
- +52 ; delete 408.22
- +53 ;
- +54 SET DA=$GET(DGINR("V"))
- Begin DoDot:1
- +55 if 'DA
- QUIT
- SET DIK="^DGMT(408.22,"
- DO ^DIK
- End DoDot:1
- +56 SET DA=$GET(DGINR("S"))
- Begin DoDot:1
- +57 if 'DA
- QUIT
- SET DIK="^DGMT(408.22,"
- DO ^DIK
- End DoDot:1
- +58 SET IVMN=0
- +59 FOR
- SET IVMN=$ORDER(DGINR("C",IVMN))
- if 'IVMN
- QUIT
- SET DA=$GET(DGINR("C",IVMN))
- SET DIK="^DGMT(408.22,"
- DO ^DIK
- +60 ;
- +61 ; delete 408.21
- +62 ;
- +63 SET DA=$GET(DGINC("V"))
- Begin DoDot:1
- +64 if 'DA
- QUIT
- SET DIK="^DGMT(408.21,"
- DO ^DIK
- End DoDot:1
- +65 SET DA=$GET(DGINC("S"))
- Begin DoDot:1
- +66 if 'DA
- QUIT
- SET DIK="^DGMT(408.21,"
- DO ^DIK
- End DoDot:1
- +67 SET IVMN=0
- +68 FOR
- SET IVMN=$ORDER(DGINC("C",IVMN))
- if 'IVMN
- QUIT
- SET DA=$GET(DGINC("C",IVMN))
- SET DIK="^DGMT(408.21,"
- DO ^DIK
- +69 ;
- +70 ; logic for 408.12/408.1275 & 408.13
- +71 ;
- +72 DO SETUPAR^IVMUM8
- +73 ;
- +74 ; no "AIVM" x-ref means
- +75 ; no dependents
- +76 ; or
- +77 ; IVM v2.0 means test (no dependent difference)
- +78 ; only 408.22, 408.21, and 408.31 records will be deleted
- +79 ;
- +80 SET IVM12=""
- FOR
- SET IVM12=$ORDER(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12))
- if 'IVM12
- QUIT
- Begin DoDot:1
- +81 IF $GET(^DGPR(408.12,+IVM12,0))']""
- Begin DoDot:2
- +82 SET (IVMTEXT(6),HLERR)="Can't find 408.12 record "_IVM12
- +83 DO ERRBULL^IVMPREC7
- DO MAIL^IVMUFNC()
- +84 SET IVMFERR=""
- +85 DO ACK^IVMPREC
- +86 QUIT
- End DoDot:2
- QUIT
- +87 ;
- +88 IF $PIECE($GET(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1
- Begin DoDot:2
- +89 ; only 1 multiple record (408.1275) indicates IVM dependent
- +90 ; delete 408.12 & 408.13 records for IVM dependent
- +91 SET IVM13=$PIECE($PIECE($GET(^DGPR(408.12,+IVM12,0)),"^",3),";")
- IF $GET(^DGPR(408.13,+IVM13,0))']""
- Begin DoDot:3
- +92 SET (IVMTEXT(6),HLERR)="Can't find 408.13 record "_IVM13
- +93 DO ERRBULL^IVMPREC7
- DO MAIL^IVMUFNC()
- +94 SET IVMFERR=""
- +95 DO ACK^IVMPREC
- +96 QUIT
- End DoDot:3
- QUIT
- +97 SET DA=IVM12
- SET DIK="^DGPR(408.12,"
- DO ^DIK
- KILL DA,DIK
- +98 SET DA=IVM13
- SET DIK="^DGPR(408.13,"
- DO ^DIK
- KILL DA,DIK
- +99 QUIT
- End DoDot:2
- QUIT
- +100 ;
- +101 ; delete 408.1275 record for IVM dependent and
- +102 ; change demo data in 408.12 & 408.13 back to VAMC values
- +103 ; or
- +104 ; delete 408.1275 record for inactivated VAMC dependent
- +105 SET IVM121=""
- SET IVM121=$ORDER(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))
- +106 IF $GET(^DGPR(408.12,+IVM12,"E",+IVM121,0))']""
- Begin DoDot:2
- +107 SET (IVMTEXT(6),HLERR)="Can't find 408.1275 record "_IVM12_" "_IVM121
- +108 DO ERRBULL^IVMPREC7
- DO MAIL^IVMUFNC()
- +109 SET IVMFERR=""
- +110 DO ACK^IVMPREC
- +111 QUIT
- End DoDot:2
- QUIT
- +112 ; dependent active?
- SET IVMVAMCA=$PIECE(^(0),"^",2)
- +113 SET DA(1)=IVM12
- SET DA=IVM121
- SET DIK="^DGPR(408.12,"_DA(1)_",""E"","
- +114 DO ^DIK
- KILL DA(1),DA,DIK
- +115 ; quit if inactivated VAMC dependent
- if 'IVMVAMCA
- QUIT
- +116 SET IVM13=+$PIECE($PIECE($GET(^DGPR(408.12,+IVM12,0)),"^",3),";")
- +117 DO EN^IVMUM8
- +118 QUIT
- End DoDot:1
- if $DATA(IVMFERR)
- QUIT
- +119 ;
- +120 if $DATA(IVMFERR)
- QUIT
- +121 DO EN1^IVMUM8
- +122 QUIT