DG53358D ;ALB/AEG,GN DG*5.3*358 DELETE INCOME TESTS ; 12/17/03 3:06pm
;;5.3;REGISTRATION;**358,558,1015**;5-1-2001;Build 21
;
;This is a modified version of IVMCMD in that it calls a modified
;version of IVMCMD1 called DG53358C which only deletes the
;records from the Annual Means Test(#408.31) file. It does not open
;a case record in the IVM Patient (#301.5)file, does not send 'delete'
;bulletin/notification to local mail group, does not call the means
;test event driver and does not call DGMTR.
;
;DG*53*558 - re-deploy with this patch
;
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
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)
;don't delete copay test linked to valid means test
I IVMTOT=2,IVMLINK,$D(^DGMT(408.31,IVMLINK,0)) Q 0
I IVMTOT=1,IVMLINK D I $D(IVMERR) Q 0 ;I MT linkd to copay delete both
.D DELETE(IVMLINK,DFN,IVMDOT) ; delete copay
D DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
Q IVMDONE
;
DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
;
; 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?
.;
.; - If active, inactivate dependant
.I IVMVAMCA D
..S DR=".02////0",DA=+IVM121,DA(1)=0
..S DIE="^DGPR(408.12,"_+IVM12_",""E"","
..D ^DIE S IVMVAMCA=0 Q
.;
.S DA(1)=IVM12,DA=IVM121,DIK="^DGPR(408.12,"_DA(1)_",""E"","
.D ^DIK K DA(1),DA,DIK
.;
.Q
;
; Complete deletion of income test
D EN^DG53358C
;
ENQ 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 PRMYTEST",$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
DG53358D ;ALB/AEG,GN DG*5.3*358 DELETE INCOME TESTS ; 12/17/03 3:06pm
+1 ;;5.3;REGISTRATION;**358,558,1015**;5-1-2001;Build 21
+2 ;
+3 ;This is a modified version of IVMCMD in that it calls a modified
+4 ;version of IVMCMD1 called DG53358C which only deletes the
+5 ;records from the Annual Means Test(#408.31) file. It does not open
+6 ;a case record in the IVM Patient (#301.5)file, does not send 'delete'
+7 ;bulletin/notification to local mail group, does not call the means
+8 ;test event driver and does not call DGMTR.
+9 ;
+10 ;DG*53*558 - re-deploy with this patch
+11 ;
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
+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 ;don't delete copay test linked to valid means test
+8 IF IVMTOT=2
IF IVMLINK
IF $DATA(^DGMT(408.31,IVMLINK,0))
QUIT 0
+9 ;I MT linkd to copay delete both
IF IVMTOT=1
IF IVMLINK
Begin DoDot:1
+10 ; delete copay
DO DELETE(IVMLINK,DFN,IVMDOT)
End DoDot:1
IF $DATA(IVMERR)
QUIT 0
+11 ; delete copay or MT
DO DELETE(IVMMTIEN,DFN,IVMDOT)
+12 QUIT IVMDONE
+13 ;
DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
+1 ;
+2 ; Get Income Relation IEN array (DGINR) and
+3 ; Individual Annual Income IEN array (DGINC)
+4 DO ALL^DGMTU21(DFN,"VSC",IVMDOT,"IR",IVMMTIEN)
+5 ;
+6 ;
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
+33 ;IVM/DCD dependent to delete
+34 IF $PIECE($GET(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1
Begin DoDot:2
+35 ;
+36 ; -- if can't find entry in (#408.13), set IVMERR
+37 SET IVM13=$PIECE($PIECE($GET(^DGPR(408.12,+IVM12,0)),"^",3),";")
+38 IF $GET(^DGPR(408.13,+IVM13,0))']""
Begin DoDot:3
+39 SET IVMERR=""
QUIT
End DoDot:3
QUIT
+40 ;
+41 ; -- delete (#408.12) & (#408.13) records for IVM/DCD dependent
+42 SET DA=IVM12
SET DIK="^DGPR(408.12,"
DO ^DIK
KILL DA,DIK
+43 SET DA=IVM13
SET DIK="^DGPR(408.13,"
DO ^DIK
KILL DA,DIK
+44 QUIT
End DoDot:2
QUIT
+45 ;
+46 ;
+47 ; Delete (#408.1275) record for IVM/DCD dependent and
+48 ; change demo data in (#408.12) & (#408.13) back to VAMC values.
+49 ; OR, Delete (#408.1275) record for inactivated VAMC dependent.
+50 SET IVM121=""
SET IVM121=$ORDER(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))
+51 ; - if can't find entry in (#408.1275), set IVMERR
+52 IF $GET(^DGPR(408.12,+IVM12,"E",+IVM121,0))']""
Begin DoDot:2
+53 SET IVMERR=""
QUIT
End DoDot:2
QUIT
+54 ;
+55 SET IVMVAMCA=$PIECE($GET(^DGPR(408.12,+IVM12,"E",+IVM121,0)),"^",2)
+56 ;dependent active?
+57 ;
+58 ; - If active, inactivate dependant
+59 IF IVMVAMCA
Begin DoDot:2
+60 SET DR=".02////0"
SET DA=+IVM121
SET DA(1)=0
+61 SET DIE="^DGPR(408.12,"_+IVM12_",""E"","
+62 DO ^DIE
SET IVMVAMCA=0
QUIT
End DoDot:2
+63 ;
+64 SET DA(1)=IVM12
SET DA=IVM121
SET DIK="^DGPR(408.12,"_DA(1)_",""E"","
+65 DO ^DIK
KILL DA(1),DA,DIK
+66 ;
+67 QUIT
End DoDot:1
IF $DATA(IVMERR)
QUIT
+68 ;
+69 ; Complete deletion of income test
+70 DO EN^DG53358C
+71 ;
ENQ QUIT
+1 ;
+2 ;
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 PRMYTEST",$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
