IVMCMD ;ALB/SEK,KCL,BRM - DELETE DCD INCOME TESTS ; 12/18/01 1:18pm
;;2.0;INCOME VERIFICATION MATCH;**17,33,49,187**;21-OCT-94;Build 3
;
;
;
EN(IVMMTIEN) ; --
; This routine will process income test deletion requests received
; from the IVM Center.
;
; Input(s):
; IVMMTIEN - pointer to test to be deleted in file 408.31
;
; Output(s):
; Function Value - 1 test deleted
; 0 test not deleted
;
;
; Initialize variables
N DFN,IVMERR,IVMLINK,IVMNODE0,IVMDOT,IVMTOT,IVMDONE,IVMLTC
S IVMDONE=0
;
EN1 ; Get zero node of (#408.31)
S IVMNODE0=$G(^DGMT(408.31,IVMMTIEN,0))
I 'IVMNODE0 Q 1 ; test not found
S IVMDOT=$P(IVMNODE0,"^") ; date of test
S DFN=$P(IVMNODE0,"^",2)
S IVMTOT=$P(IVMNODE0,"^",19) ; type of test
S IVMLINK=$P($G(^DGMT(408.31,IVMMTIEN,2)),"^",6)
I IVMTOT=1,$D(^DGMT(408.31,"AT",IVMMTIEN)) S IVMLTC=$O(^DGMT(408.31,"AT",IVMMTIEN,""))
I IVMTOT=2,IVMLINK Q 0 ; don't delete copay test linked to means test
I IVMTOT=1 D I $D(IVMERR) Q 0 ;if MT linked, delete linked test
.D:IVMLINK DELETE(IVMLINK,DFN,IVMDOT) ; delete copay test
.D:$G(IVMLTC) DELETE(IVMLTC,DFN,IVMDOT) ; delete LTC test
;
D DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
Q IVMDONE
;
DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
;
; Handle LTC test deletion if there is an associated Means Test
I $P($G(^DGMT(408.31,+IVMMTIEN,0)),"^",19)=4,+$P($G(^DGMT(408.31,+IVMMTIEN,2)),"^",8) D DEL31^IVMCMD1(IVMMTIEN) Q
;
; Set DGMTP prior to delete
N DGMTP
S DGMTACT="DEL",DGMTI=IVMMTIEN D PRIOR^DGMTEVT
;
; Get Income Relation IEN array (DGINR) and
; Individual Annual Income IEN array (DGINC)
D ALL^DGMTU21(DFN,"VSC",IVMDOT,"IR",IVMMTIEN)
;
;
DEL22 ; Delete veteran, spouse, and dependent entries from the
; Income Relation (#408.22) file:
; - Veteran (#408.22) record
S DA=$G(DGINR("V")) D
.Q:'DA
.S DIK="^DGMT(408.22,"
.D ^DIK
;
; - Spouse (#408.22) record
S DA=$G(DGINR("S")) D
.Q:'DA
.S DIK="^DGMT(408.22,"
.D ^DIK
;
; - All dependent children (#408.22) records
S IVMDEP=0
F S IVMDEP=$O(DGINR("C",IVMDEP)) Q:'IVMDEP D
.S DA=$G(DGINR("C",IVMDEP))
.S DIK="^DGMT(408.22,"
.D ^DIK
;
;
DEL21 ; Delete veteran, spouse, and dependent entries from
; Individual Annual Income (#408.21) file:
; - Veteran (#408.21) record
S DA=$G(DGINC("V")) D
.Q:'DA
.S DIK="^DGMT(408.21,"
.D ^DIK
;
; - Spouse (#408.21) record
S DA=$G(DGINC("S")) D
.Q:'DA
.S DIK="^DGMT(408.21,"
.D ^DIK
;
; - All dependent children (#408.21) records
S IVMDEP=0
F S IVMDEP=$O(DGINC("C",IVMDEP)) Q:'IVMDEP D
.S DA=$G(DGINC("C",IVMDEP))
.S DIK="^DGMT(408.21,"
.D ^DIK
;
;
; Logic for (#408.12/#408.1275) & (#408.13) file entries
D SETUPAR
;
; Look for IVM/DCD Patient Realtion (#408.12) file entries.
; If no entries in "AIVM" x-ref, no dependent changes required.
S IVM12="" F S IVM12=$O(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12)) Q:'IVM12 D Q:$D(IVMERR)
.; - if can't find entry in (#408.12), set IVMERR
.I $G(^DGPR(408.12,+IVM12,0))']"" D Q
..S IVMERR="" Q
.;
.; - if only one record exists in (#408.1275) mult., then only one IVM/DCD dependent to delete
.I $P($G(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1 D Q
..;
..; -- if can't find entry in (#408.13), set IVMERR
..S IVM13=$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";") I $G(^DGPR(408.13,+IVM13,0))']"" D Q
...S IVMERR="" Q
..;
..; -- delete (#408.12) & (#408.13) records for IVM/DCD dependent
..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/DCD 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))
.; - if can't find entry in (#408.1275), set IVMERR
.I $G(^DGPR(408.12,+IVM12,"E",+IVM121,0))']"" D Q
..S IVMERR="" Q
.;
.S IVMVAMCA=$P($G(^DGPR(408.12,+IVM12,"E",+IVM121,0)),"^",2) ; dependent active?
.S DA(1)=IVM12,DA=IVM121,DIK="^DGPR(408.12,"_DA(1)_",""E"","
.D ^DIK K DA(1),DA,DIK
.;
.; - quit if inactivated VAMC dependent
.Q:'IVMVAMCA
.;
.; - get pointer to Income Person (#408.13) file
.S IVM13=+$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";")
.;
.; - change demo data back to original values
.D DEMO
.Q
;
; Complete deletion of income test
D EN^IVMCMD1
;
ENQ Q
;
;
DEMO ; Change demographic data in (#408.12) & (#408.13) files
; back to original VAMC values.
;
; Input(s):
; IVM12 - as IEN of (#408.12) file
; IVM13 - as IEN of (#408.13) file
; IVMMTIEN - as IEN of (#408.31) file
;
; Output(s): None
;
; NOTE: File (#408.13) fields were added to (#408.41) file before
; file (#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
;
;
SETUPAR ; Create array IVMAR1() where
; 1) Subscript is MT Changes Type (#408.42) file node where type of
; change = Name, DOB, SSN, Sex, Relationship.
; 2) 1st piece is (#408.12) or (#408.13) file.
; 3) 2nd piece is (#408.12) or (#408.13) file field number.
;
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
;
DELTYPE(DFN,MTDATE,TYPE) ;
;will delete any primary test for patient=DFN for same income year as
;MTDATE for test of type=TYPE
;
Q:'$G(DFN)
Q:'$G(MTDATE)
Q:'$G(TYPE)
N MTNODE,YEAR,RET
S YEAR=$E(MTDATE,1,3)_1230.999999
D
.S MTNODE=$$LST^DGMTU(DFN,YEAR,TYPE)
.Q:'+MTNODE
.I $E($P(MTNODE,"^",2),1,3)'=$E(YEAR,1,3) Q
.;don't want to delete auto-created Rx copay tests -they are deleted by
.; deleting the MT that they are based on
.I TYPE=2,+$P($G(^DGMT(408.31,+MTNODE,2)),"^",6) Q
.I $P(MTNODE,"^",5),$P(MTNODE,"^",5)'=1 I $$EN(+MTNODE) D
..;
..S RET=$$LST^DGMTU(DFN,DT,IVMTYPE)
..I $E($P(RET,"^",2),1,3)'=$E(YEAR,1,3) S RET=""
..D ADD^IVMCMB(DFN,IVMTYPE,"DELETE PRMY TEST",$P(MTNODE,"^",2),$P(MTNODE,"^",4),$P(RET,"^",4))
Q
;
TYPECH ; Type of dependent changes (#408.41/#408.42) file
; 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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMCMD 6876 printed Sep 23, 2025@19:36:42 Page 2
IVMCMD ;ALB/SEK,KCL,BRM - DELETE DCD INCOME TESTS ; 12/18/01 1:18pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**17,33,49,187**;21-OCT-94;Build 3
+2 ;
+3 ;
+4 ;
EN(IVMMTIEN) ; --
+1 ; This routine will process income test deletion requests received
+2 ; from the IVM Center.
+3 ;
+4 ; Input(s):
+5 ; IVMMTIEN - pointer to test to be deleted in file 408.31
+6 ;
+7 ; Output(s):
+8 ; Function Value - 1 test deleted
+9 ; 0 test not deleted
+10 ;
+11 ;
+12 ; Initialize variables
+13 NEW DFN,IVMERR,IVMLINK,IVMNODE0,IVMDOT,IVMTOT,IVMDONE,IVMLTC
+14 SET IVMDONE=0
+15 ;
EN1 ; Get zero node of (#408.31)
+1 SET IVMNODE0=$GET(^DGMT(408.31,IVMMTIEN,0))
+2 ; test not found
IF 'IVMNODE0
QUIT 1
+3 ; date of test
SET IVMDOT=$PIECE(IVMNODE0,"^")
+4 SET DFN=$PIECE(IVMNODE0,"^",2)
+5 ; type of test
SET IVMTOT=$PIECE(IVMNODE0,"^",19)
+6 SET IVMLINK=$PIECE($GET(^DGMT(408.31,IVMMTIEN,2)),"^",6)
+7 IF IVMTOT=1
IF $DATA(^DGMT(408.31,"AT",IVMMTIEN))
SET IVMLTC=$ORDER(^DGMT(408.31,"AT",IVMMTIEN,""))
+8 ; don't delete copay test linked to means test
IF IVMTOT=2
IF IVMLINK
QUIT 0
+9 ;if MT linked, delete linked test
IF IVMTOT=1
Begin DoDot:1
+10 ; delete copay test
if IVMLINK
DO DELETE(IVMLINK,DFN,IVMDOT)
+11 ; delete LTC test
if $GET(IVMLTC)
DO DELETE(IVMLTC,DFN,IVMDOT)
End DoDot:1
IF $DATA(IVMERR)
QUIT 0
+12 ;
+13 ; delete copay or MT
DO DELETE(IVMMTIEN,DFN,IVMDOT)
+14 QUIT IVMDONE
+15 ;
DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
+1 ;
+2 ; Handle LTC test deletion if there is an associated Means Test
+3 IF $PIECE($GET(^DGMT(408.31,+IVMMTIEN,0)),"^",19)=4
IF +$PIECE($GET(^DGMT(408.31,+IVMMTIEN,2)),"^",8)
DO DEL31^IVMCMD1(IVMMTIEN)
QUIT
+4 ;
+5 ; Set DGMTP prior to delete
+6 NEW DGMTP
+7 SET DGMTACT="DEL"
SET DGMTI=IVMMTIEN
DO PRIOR^DGMTEVT
+8 ;
+9 ; Get Income Relation IEN array (DGINR) and
+10 ; Individual Annual Income IEN array (DGINC)
+11 DO ALL^DGMTU21(DFN,"VSC",IVMDOT,"IR",IVMMTIEN)
+12 ;
+13 ;
DEL22 ; Delete veteran, spouse, and dependent entries from the
+1 ; Income Relation (#408.22) file:
+2 ; - Veteran (#408.22) record
+3 SET DA=$GET(DGINR("V"))
Begin DoDot:1
+4 if 'DA
QUIT
+5 SET DIK="^DGMT(408.22,"
+6 DO ^DIK
End DoDot:1
+7 ;
+8 ; - Spouse (#408.22) record
+9 SET DA=$GET(DGINR("S"))
Begin DoDot:1
+10 if 'DA
QUIT
+11 SET DIK="^DGMT(408.22,"
+12 DO ^DIK
End DoDot:1
+13 ;
+14 ; - All dependent children (#408.22) records
+15 SET IVMDEP=0
+16 FOR
SET IVMDEP=$ORDER(DGINR("C",IVMDEP))
if 'IVMDEP
QUIT
Begin DoDot:1
+17 SET DA=$GET(DGINR("C",IVMDEP))
+18 SET DIK="^DGMT(408.22,"
+19 DO ^DIK
End DoDot:1
+20 ;
+21 ;
DEL21 ; Delete veteran, spouse, and dependent entries from
+1 ; Individual Annual Income (#408.21) file:
+2 ; - Veteran (#408.21) record
+3 SET DA=$GET(DGINC("V"))
Begin DoDot:1
+4 if 'DA
QUIT
+5 SET DIK="^DGMT(408.21,"
+6 DO ^DIK
End DoDot:1
+7 ;
+8 ; - Spouse (#408.21) record
+9 SET DA=$GET(DGINC("S"))
Begin DoDot:1
+10 if 'DA
QUIT
+11 SET DIK="^DGMT(408.21,"
+12 DO ^DIK
End DoDot:1
+13 ;
+14 ; - All dependent children (#408.21) records
+15 SET IVMDEP=0
+16 FOR
SET IVMDEP=$ORDER(DGINC("C",IVMDEP))
if 'IVMDEP
QUIT
Begin DoDot:1
+17 SET DA=$GET(DGINC("C",IVMDEP))
+18 SET DIK="^DGMT(408.21,"
+19 DO ^DIK
End DoDot:1
+20 ;
+21 ;
+22 ; Logic for (#408.12/#408.1275) & (#408.13) file entries
+23 DO SETUPAR
+24 ;
+25 ; Look for IVM/DCD Patient Realtion (#408.12) file entries.
+26 ; If no entries in "AIVM" x-ref, no dependent changes required.
+27 SET IVM12=""
FOR
SET IVM12=$ORDER(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12))
if 'IVM12
QUIT
Begin DoDot:1
+28 ; - if can't find entry in (#408.12), set IVMERR
+29 IF $GET(^DGPR(408.12,+IVM12,0))']""
Begin DoDot:2
+30 SET IVMERR=""
QUIT
End DoDot:2
QUIT
+31 ;
+32 ; - if only one record exists in (#408.1275) mult., then only one IVM/DCD dependent to delete
+33 IF $PIECE($GET(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1
Begin DoDot:2
+34 ;
+35 ; -- if can't find entry in (#408.13), set IVMERR
+36 SET IVM13=$PIECE($PIECE($GET(^DGPR(408.12,+IVM12,0)),"^",3),";")
IF $GET(^DGPR(408.13,+IVM13,0))']""
Begin DoDot:3
+37 SET IVMERR=""
QUIT
End DoDot:3
QUIT
+38 ;
+39 ; -- delete (#408.12) & (#408.13) records for IVM/DCD dependent
+40 SET DA=IVM12
SET DIK="^DGPR(408.12,"
DO ^DIK
KILL DA,DIK
+41 SET DA=IVM13
SET DIK="^DGPR(408.13,"
DO ^DIK
KILL DA,DIK
+42 QUIT
End DoDot:2
QUIT
+43 ;
+44 ;
+45 ; Delete (#408.1275) record for IVM/DCD dependent and
+46 ; change demo data in (#408.12) & (#408.13) back to VAMC values.
+47 ; OR, Delete (#408.1275) record for inactivated VAMC dependent.
+48 SET IVM121=""
SET IVM121=$ORDER(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))
+49 ; - if can't find entry in (#408.1275), set IVMERR
+50 IF $GET(^DGPR(408.12,+IVM12,"E",+IVM121,0))']""
Begin DoDot:2
+51 SET IVMERR=""
QUIT
End DoDot:2
QUIT
+52 ;
+53 ; dependent active?
SET IVMVAMCA=$PIECE($GET(^DGPR(408.12,+IVM12,"E",+IVM121,0)),"^",2)
+54 SET DA(1)=IVM12
SET DA=IVM121
SET DIK="^DGPR(408.12,"_DA(1)_",""E"","
+55 DO ^DIK
KILL DA(1),DA,DIK
+56 ;
+57 ; - quit if inactivated VAMC dependent
+58 if 'IVMVAMCA
QUIT
+59 ;
+60 ; - get pointer to Income Person (#408.13) file
+61 SET IVM13=+$PIECE($PIECE($GET(^DGPR(408.12,+IVM12,0)),"^",3),";")
+62 ;
+63 ; - change demo data back to original values
+64 DO DEMO
+65 QUIT
End DoDot:1
if $DATA(IVMERR)
QUIT
+66 ;
+67 ; Complete deletion of income test
+68 DO EN^IVMCMD1
+69 ;
ENQ QUIT
+1 ;
+2 ;
DEMO ; Change demographic data in (#408.12) & (#408.13) files
+1 ; back to original VAMC values.
+2 ;
+3 ; Input(s):
+4 ; IVM12 - as IEN of (#408.12) file
+5 ; IVM13 - as IEN of (#408.13) file
+6 ; IVMMTIEN - as IEN of (#408.31) file
+7 ;
+8 ; Output(s): None
+9 ;
+10 ; NOTE: File (#408.13) fields were added to (#408.41) file before
+11 ; file (#408.12) field.
+12 ;
+13 KILL DR
SET IVM41=0
+14 FOR
SET IVM41=$ORDER(^DGMT(408.41,"D",IVMMTIEN,IVM41))
if 'IVM41
QUIT
Begin DoDot:1
+15 SET IVM411=$GET(^DGMT(408.41,+IVM41,0))
+16 if $PIECE(IVM411,"^",10)'=IVM13
QUIT
+17 SET IVMOLD=$PIECE(IVM411,"^",5)
+18 SET IVMOLD=$SELECT(IVMOLD="":"@",1:IVMOLD)
+19 SET IVMFILE=$PIECE(IVMAR1($PIECE(IVM411,"^",2)),";")
+20 SET IVMNOD=$PIECE(IVMAR1($PIECE(IVM411,"^",2)),";",2)
+21 IF IVMFILE=408.13
SET DA=IVM13
SET DIE="^DGPR(408.13,"
+22 IF IVMFILE=408.12
SET DA=IVM12
SET DIE="^DGPR(408.12,"
+23 SET DR=IVMNOD_"////^S X=IVMOLD"
+24 DO ^DIE
KILL DA,DR,DIE
End DoDot:1
+25 QUIT
+26 ;
+27 ;
SETUPAR ; Create array IVMAR1() where
+1 ; 1) Subscript is MT Changes Type (#408.42) file node where type of
+2 ; change = Name, DOB, SSN, Sex, Relationship.
+3 ; 2) 1st piece is (#408.12) or (#408.13) file.
+4 ; 3) 2nd piece is (#408.12) or (#408.13) file field number.
+5 ;
+6 FOR IVM41=4:1
SET IVM411=$PIECE($TEXT(TYPECH+IVM41),";;",2)
if IVM411="QUIT"
QUIT
Begin DoDot:1
+7 SET IVMAR1($PIECE(IVM411,";"))=$PIECE(IVM411,";",2,3)
End DoDot:1
+8 KILL IVM41,IVM411
+9 QUIT
+10 ;
DELTYPE(DFN,MTDATE,TYPE) ;
+1 ;will delete any primary test for patient=DFN for same income year as
+2 ;MTDATE for test of type=TYPE
+3 ;
+4 if '$GET(DFN)
QUIT
+5 if '$GET(MTDATE)
QUIT
+6 if '$GET(TYPE)
QUIT
+7 NEW MTNODE,YEAR,RET
+8 SET YEAR=$EXTRACT(MTDATE,1,3)_1230.999999
+9 Begin DoDot:1
+10 SET MTNODE=$$LST^DGMTU(DFN,YEAR,TYPE)
+11 if '+MTNODE
QUIT
+12 IF $EXTRACT($PIECE(MTNODE,"^",2),1,3)'=$EXTRACT(YEAR,1,3)
QUIT
+13 ;don't want to delete auto-created Rx copay tests -they are deleted by
+14 ; deleting the MT that they are based on
+15 IF TYPE=2
IF +$PIECE($GET(^DGMT(408.31,+MTNODE,2)),"^",6)
QUIT
+16 IF $PIECE(MTNODE,"^",5)
IF $PIECE(MTNODE,"^",5)'=1
IF $$EN(+MTNODE)
Begin DoDot:2
+17 ;
+18 SET RET=$$LST^DGMTU(DFN,DT,IVMTYPE)
+19 IF $EXTRACT($PIECE(RET,"^",2),1,3)'=$EXTRACT(YEAR,1,3)
SET RET=""
+20 DO ADD^IVMCMB(DFN,IVMTYPE,"DELETE PRMY TEST",$PIECE(MTNODE,"^",2),$PIECE(MTNODE,"^",4),$PIECE(RET,"^",4))
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
TYPECH ; Type of dependent changes (#408.41/#408.42) file
+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
+10 QUIT
