DG53426D ;ALB/AEG - DG*5.3*426 POST-INSTALLATION ;2-19-02
;;5.3;Registration;**426,1015**;2-19-02;Build 21
;
; This routine is a modified version of IVMCMD in that it calls a
; modified version of IVMCMD1 called DG53426E which only deletes the
; records from the ANNUAL MEANS TEST file (#408.31). It does NOT
; send a 'delete' bulletin/notification to the local mail group. It
; will create a case record in the IVM Patient file (#301.5) and it
; does call the means test event driver and will call the post-install
; version of DGMTR.
;
EN(MTIEN) ;
; This line tage will process an income test deletion request from
; the post-installation portion of patch DG*5.3*426.
;
; Input - MTIEN = IEN of REQUIRED test to be deleted in file 408.31.
;
; Output(s):
; Function Value: - 1 test deleted successfully.
; 0 test not deleted.
;
; init variables
N DFN,DGERR,DGLINK,DGNODE0,DGDOT,DGTOT,DGDONE
S DGDONE=0
;
EN1 ; Get zeroth node of file 408.31 entry.
S DGNODE0=$G(^DGMT(408.31,MTIEN,0))
I 'DGNODE0 Q 1
S DGDOT=$P($G(DGNODE0),U,1),DGTOT=$P($G(DGNODE0),U,19)
S DFN=$P($G(DGNODE0),U,2),DGLINK=$P($G(^DGMT(408.31,MTIEN,2)),U,6)
I DGTOT=2,DGLINK Q 0
I DGTOT=1,DGLINK D I $G(DGERR) Q 0
.D DELETE(DGLINK,DFN,DGDOT) ; delete copay
D DELETE(MTIEN,DFN,DGDOT)
Q DGDONE
;
DELETE(MTIEN,DFN,DGDOT) ;delete a copay or MT
;
;Set DGMTP prior to deleting records
S DGMTACT="DEL",DGMTI=MTIEN D PRIOR^DGMTEVT
; Individual annual Income array (DGINC)
D ALL^DGMTU21(DFN,"VSC",DGDOT,"IR",MTIEN)
;
DEL22 ; Delete veteran, spouse, & dependent entries from the Income Relation
; (#408.22) file:
;
; - Veteran #408.22 record IEN
S DA=$G(DGINR("V")) D
.Q:'DA
.S DIK="^DGMT(408.22,"
.L +^DGMT(408.22,DA):1
.D ^DIK,IX1^DIK
.L -^DGMT(408.22,DA)
.K DA,DIK
;
; - Spouse 408.22 record
S DA=$G(DGINR("S")) D
.Q:'DA
.S DIK="^DGMT(408.22,"
.L +^DGMT(408.22,DA):1
.D ^DIK,IX1^DIK
.L -^DGMT(408.22,DA)
.K DA,DIK
;
; - All Dependent Children entries in file 408.22
S DGDEP=0
F S DGDEP=$O(DGINR("C",DGDEP)) Q:'DGDEP D
.S DA=$G(DGINR("C",DGDEP))
.S DIK="^DGMT(408.22,"
.L +^DGMT(408.22,DA):1
.D ^DIK,IX1^DIK
.K DA,DIK
;
DEL21 ; Delete veteran, spouse, & dependent children entries from the
; Individual Annual Income (#408.21) file:
S DA=$G(DGINC("V")) D
.Q:'DA
.S DIK="^DGMT(408.21,"
.L +^DGMT(408.21,DA):1
.D ^DIK,IX1^DIK
.L -^DGMT(408.21,DA)
.K DA,DIK
;
; Spouse
S DA=$G(DGINC("S")) D
.Q:'DA
.S DIK="^DGMT(408.21,"
.L +^DGMT(408.21,DA):1
.D ^DIK,IX1^DIK
.L -^DGMT(408.21,DA)
.K DA,DIK
;
; ALL Depn. Children
S DGDEP=0
F S DGDEP=$O(DGINC("C",DGDEP)) Q:'DGDEP D
.S DA=$G(DGINC("C",DGDEP)),DIK="^DGMT(408.21,"
.L +^DGMT(408.21,DA):1
.D ^DIK,IX1^DIK
.L -^DGMT(408.21,DA)
.K DA,DIK
;
; Logic for #408.12, #408.1275 & #408.13 file enties.
D SETUPAR
;
; look for IVM Patient relation file entries. If no entries in "AIVM"
; x-ref, no dependent changes are required.
S DG12="" F S DG12=$O(^DGPR(408.12,"AIVM",MTIEN,DG12)) Q:'DG12 D Q:$D(DGERR)
.; if any entry cannot be found in 408.12 set DGERR
.I $G(^DGPR(408.12,+DG12,0))']"" D Q
..S DGERR="" Q
.;
.; if only 1 record exists in the 408.1275 multiple then only 1
.; dependent to delete
.I $P($G(^DGPR(408.13,+DG12,"E",0)),U,4)=1 D Q
..;
..S DG13=$P($P($G(^DGPR(408.12,+DG12,0)),U,3),";")
..I $G(^DGPR(408.13,+DG13,0))']"" D Q
...S DGERR="" Q
..;
..; Delete 408.12 & 408.13 records for dependent
..S DA=DG12,DIK="^DGPR(408.12," D ^DIK,IX1^DIK K DA,DIK
..S DA=DG13,DIK="^DGPR(408.13," D ^DIK,IX1^DIK K DA,DIK
..Q
.;
.; Delete #408.1275 multi. entry from dependent and change demo
.; data in 408.12 & 408.13 back to VAMC values. OR delete 408.1275
.; entry from inactivated VAMC dependent.
.; if no entry found in multiple --- set DGERR
.S DG121="",DG121=$O(^DGPR(408.12,"AIVM",MTIEN,+DG12,DG121))
.; if no entry is found in multiple set DGERR
.I $G(^DGPR(408.12,+DG12,"E",+DG121,0))']"" D Q
..S DGERR="" Q
.;
.S DGVACMA=$P($G(^DGPR(408.12,+DG12,"E",+DG121,0)),U,2)
.; Active depend?
.I DGVACMA D
..S DR=".02////0",DA=+DG121,DA(1)=0
..S DIE="^DGPR(408.12,"_+DG12_",""E"","
..D ^DIE S DGVACMA=0 Q
.;
.S DA(1)=DG12,DA=DG121,DIK="^DGPR(408.12,"_DA(1)_",""E"","
.D ^DIK K DA(1),DA,DIK
.;
.Q
;
; Complete the deletion of an income test.
D EN^DG53426E
;
ENQ Q
;
;
SETUPAR ; Create data array DGMAR1() 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 DG41=4:1 S DG411=$P($T(TYPECH+DG41),";;",2) Q:DG411="QUIT" D
.S DGMAR($P(DG411,";"))=$P(DG411,";",2,3)
K DG41,DG411
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 DGNODE,DGYEAR,RET
S DGYEAR=$E(MTDATE,1,3)_1230.99999
D
.S DGNODE=$$LST^DGMTU(DGDFN,DGYEAR,TYPE)
.Q:'+DGNODE
.I $E($P(DGNODE,U,2),1,3)'=$E(YEAR,1,3) Q
.; Don't delete auto created Rx copay tests - they are deleted
.; by deleting the MT that they are linked to.
.I TYPE=2,+$P($G(^DGMT(408.31,+DGNODE,2)),U,6) Q
.I $P(DGNODE,U,5),$P(DGNODE,U,5)'=1 I $$EN(+MTNODE) D
..S RET=$$LST^DGMTU(DGDFN,DT,DGTYPE)
..I $E($P(RET,U,2),1,3)'=$E(YEAR,1,3) S RET=""
..D ADD^IVMCMB(DGDFN,DGTYPE,"DELETE PRMYTEST",$P(DGNODE,U,2),$P(DGNODE,U,4),$P(RET,U,4))
Q
;
TYPECH ; Type of dependent change (#408.41/#408.42) file
; 1st piece - 408.42 table file node
; 2nd piece - file (#408.12 or 408.13)
; 3rd piece - 408.12 or 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
DG53426D ;ALB/AEG - DG*5.3*426 POST-INSTALLATION ;2-19-02
+1 ;;5.3;Registration;**426,1015**;2-19-02;Build 21
+2 ;
+3 ; This routine is a modified version of IVMCMD in that it calls a
+4 ; modified version of IVMCMD1 called DG53426E which only deletes the
+5 ; records from the ANNUAL MEANS TEST file (#408.31). It does NOT
+6 ; send a 'delete' bulletin/notification to the local mail group. It
+7 ; will create a case record in the IVM Patient file (#301.5) and it
+8 ; does call the means test event driver and will call the post-install
+9 ; version of DGMTR.
+10 ;
EN(MTIEN) ;
+1 ; This line tage will process an income test deletion request from
+2 ; the post-installation portion of patch DG*5.3*426.
+3 ;
+4 ; Input - MTIEN = IEN of REQUIRED test to be deleted in file 408.31.
+5 ;
+6 ; Output(s):
+7 ; Function Value: - 1 test deleted successfully.
+8 ; 0 test not deleted.
+9 ;
+10 ; init variables
+11 NEW DFN,DGERR,DGLINK,DGNODE0,DGDOT,DGTOT,DGDONE
+12 SET DGDONE=0
+13 ;
EN1 ; Get zeroth node of file 408.31 entry.
+1 SET DGNODE0=$GET(^DGMT(408.31,MTIEN,0))
+2 IF 'DGNODE0
QUIT 1
+3 SET DGDOT=$PIECE($GET(DGNODE0),U,1)
SET DGTOT=$PIECE($GET(DGNODE0),U,19)
+4 SET DFN=$PIECE($GET(DGNODE0),U,2)
SET DGLINK=$PIECE($GET(^DGMT(408.31,MTIEN,2)),U,6)
+5 IF DGTOT=2
IF DGLINK
QUIT 0
+6 IF DGTOT=1
IF DGLINK
Begin DoDot:1
+7 ; delete copay
DO DELETE(DGLINK,DFN,DGDOT)
End DoDot:1
IF $GET(DGERR)
QUIT 0
+8 DO DELETE(MTIEN,DFN,DGDOT)
+9 QUIT DGDONE
+10 ;
DELETE(MTIEN,DFN,DGDOT) ;delete a copay or MT
+1 ;
+2 ;Set DGMTP prior to deleting records
+3 SET DGMTACT="DEL"
SET DGMTI=MTIEN
DO PRIOR^DGMTEVT
+4 ; Individual annual Income array (DGINC)
+5 DO ALL^DGMTU21(DFN,"VSC",DGDOT,"IR",MTIEN)
+6 ;
DEL22 ; Delete veteran, spouse, & dependent entries from the Income Relation
+1 ; (#408.22) file:
+2 ;
+3 ; - Veteran #408.22 record IEN
+4 SET DA=$GET(DGINR("V"))
Begin DoDot:1
+5 IF 'DA
QUIT
+6 SET DIK="^DGMT(408.22,"
+7 LOCK +^DGMT(408.22,DA):1
+8 DO ^DIK
DO IX1^DIK
+9 LOCK -^DGMT(408.22,DA)
+10 KILL DA,DIK
End DoDot:1
+11 ;
+12 ; - Spouse 408.22 record
+13 SET DA=$GET(DGINR("S"))
Begin DoDot:1
+14 IF 'DA
QUIT
+15 SET DIK="^DGMT(408.22,"
+16 LOCK +^DGMT(408.22,DA):1
+17 DO ^DIK
DO IX1^DIK
+18 LOCK -^DGMT(408.22,DA)
+19 KILL DA,DIK
End DoDot:1
+20 ;
+21 ; - All Dependent Children entries in file 408.22
+22 SET DGDEP=0
+23 FOR
SET DGDEP=$ORDER(DGINR("C",DGDEP))
IF 'DGDEP
QUIT
Begin DoDot:1
+24 SET DA=$GET(DGINR("C",DGDEP))
+25 SET DIK="^DGMT(408.22,"
+26 LOCK +^DGMT(408.22,DA):1
+27 DO ^DIK
DO IX1^DIK
+28 KILL DA,DIK
End DoDot:1
+29 ;
DEL21 ; Delete veteran, spouse, & dependent children entries from the
+1 ; Individual Annual Income (#408.21) file:
+2 SET DA=$GET(DGINC("V"))
Begin DoDot:1
+3 IF 'DA
QUIT
+4 SET DIK="^DGMT(408.21,"
+5 LOCK +^DGMT(408.21,DA):1
+6 DO ^DIK
DO IX1^DIK
+7 LOCK -^DGMT(408.21,DA)
+8 KILL DA,DIK
End DoDot:1
+9 ;
+10 ; Spouse
+11 SET DA=$GET(DGINC("S"))
Begin DoDot:1
+12 IF 'DA
QUIT
+13 SET DIK="^DGMT(408.21,"
+14 LOCK +^DGMT(408.21,DA):1
+15 DO ^DIK
DO IX1^DIK
+16 LOCK -^DGMT(408.21,DA)
+17 KILL DA,DIK
End DoDot:1
+18 ;
+19 ; ALL Depn. Children
+20 SET DGDEP=0
+21 FOR
SET DGDEP=$ORDER(DGINC("C",DGDEP))
IF 'DGDEP
QUIT
Begin DoDot:1
+22 SET DA=$GET(DGINC("C",DGDEP))
SET DIK="^DGMT(408.21,"
+23 LOCK +^DGMT(408.21,DA):1
+24 DO ^DIK
DO IX1^DIK
+25 LOCK -^DGMT(408.21,DA)
+26 KILL DA,DIK
End DoDot:1
+27 ;
+28 ; Logic for #408.12, #408.1275 & #408.13 file enties.
+29 DO SETUPAR
+30 ;
+31 ; look for IVM Patient relation file entries. If no entries in "AIVM"
+32 ; x-ref, no dependent changes are required.
+33 SET DG12=""
FOR
SET DG12=$ORDER(^DGPR(408.12,"AIVM",MTIEN,DG12))
IF 'DG12
QUIT
Begin DoDot:1
+34 ; if any entry cannot be found in 408.12 set DGERR
+35 IF $GET(^DGPR(408.12,+DG12,0))']""
Begin DoDot:2
+36 SET DGERR=""
QUIT
End DoDot:2
QUIT
+37 ;
+38 ; if only 1 record exists in the 408.1275 multiple then only 1
+39 ; dependent to delete
+40 IF $PIECE($GET(^DGPR(408.13,+DG12,"E",0)),U,4)=1
Begin DoDot:2
+41 ;
+42 SET DG13=$PIECE($PIECE($GET(^DGPR(408.12,+DG12,0)),U,3),";")
+43 IF $GET(^DGPR(408.13,+DG13,0))']""
Begin DoDot:3
+44 SET DGERR=""
QUIT
End DoDot:3
QUIT
+45 ;
+46 ; Delete 408.12 & 408.13 records for dependent
+47 SET DA=DG12
SET DIK="^DGPR(408.12,"
DO ^DIK
DO IX1^DIK
KILL DA,DIK
+48 SET DA=DG13
SET DIK="^DGPR(408.13,"
DO ^DIK
DO IX1^DIK
KILL DA,DIK
+49 QUIT
End DoDot:2
QUIT
+50 ;
+51 ; Delete #408.1275 multi. entry from dependent and change demo
+52 ; data in 408.12 & 408.13 back to VAMC values. OR delete 408.1275
+53 ; entry from inactivated VAMC dependent.
+54 ; if no entry found in multiple --- set DGERR
+55 SET DG121=""
SET DG121=$ORDER(^DGPR(408.12,"AIVM",MTIEN,+DG12,DG121))
+56 ; if no entry is found in multiple set DGERR
+57 IF $GET(^DGPR(408.12,+DG12,"E",+DG121,0))']""
Begin DoDot:2
+58 SET DGERR=""
QUIT
End DoDot:2
QUIT
+59 ;
+60 SET DGVACMA=$PIECE($GET(^DGPR(408.12,+DG12,"E",+DG121,0)),U,2)
+61 ; Active depend?
+62 IF DGVACMA
Begin DoDot:2
+63 SET DR=".02////0"
SET DA=+DG121
SET DA(1)=0
+64 SET DIE="^DGPR(408.12,"_+DG12_",""E"","
+65 DO ^DIE
SET DGVACMA=0
QUIT
End DoDot:2
+66 ;
+67 SET DA(1)=DG12
SET DA=DG121
SET DIK="^DGPR(408.12,"_DA(1)_",""E"","
+68 DO ^DIK
KILL DA(1),DA,DIK
+69 ;
+70 QUIT
End DoDot:1
IF $DATA(DGERR)
QUIT
+71 ;
+72 ; Complete the deletion of an income test.
+73 DO EN^DG53426E
+74 ;
ENQ QUIT
+1 ;
+2 ;
SETUPAR ; Create data array DGMAR1() where
+1 ; 1 - Subscript is MT Changes Type (#408.42) file node where type
+2 ; of 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 DG41=4:1
SET DG411=$PIECE($TEXT(TYPECH+DG41),";;",2)
IF DG411="QUIT"
QUIT
Begin DoDot:1
+7 SET DGMAR($PIECE(DG411,";"))=$PIECE(DG411,";",2,3)
End DoDot:1
+8 KILL DG41,DG411
+9 QUIT
DELTYPE(DFN,MTDATE,TYPE) ;
+1 ; Will delete any primary test for patient (DFN) for same income
+2 ; year as MTDATE for test of type = TYPE
+3 ;
+4 IF '$GET(DFN)
QUIT
+5 IF '$GET(MTDATE)
QUIT
+6 IF '$GET(TYPE)
QUIT
+7 NEW DGNODE,DGYEAR,RET
+8 SET DGYEAR=$EXTRACT(MTDATE,1,3)_1230.99999
+9 Begin DoDot:1
+10 SET DGNODE=$$LST^DGMTU(DGDFN,DGYEAR,TYPE)
+11 IF '+DGNODE
QUIT
+12 IF $EXTRACT($PIECE(DGNODE,U,2),1,3)'=$EXTRACT(YEAR,1,3)
QUIT
+13 ; Don't delete auto created Rx copay tests - they are deleted
+14 ; by deleting the MT that they are linked to.
+15 IF TYPE=2
IF +$PIECE($GET(^DGMT(408.31,+DGNODE,2)),U,6)
QUIT
+16 IF $PIECE(DGNODE,U,5)
IF $PIECE(DGNODE,U,5)'=1
IF $$EN(+MTNODE)
Begin DoDot:2
+17 SET RET=$$LST^DGMTU(DGDFN,DT,DGTYPE)
+18 IF $EXTRACT($PIECE(RET,U,2),1,3)'=$EXTRACT(YEAR,1,3)
SET RET=""
+19 DO ADD^IVMCMB(DGDFN,DGTYPE,"DELETE PRMYTEST",$PIECE(DGNODE,U,2),$PIECE(DGNODE,U,4),$PIECE(RET,U,4))
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
TYPECH ; Type of dependent change (#408.41/#408.42) file
+1 ; 1st piece - 408.42 table file node
+2 ; 2nd piece - file (#408.12 or 408.13)
+3 ; 3rd piece - 408.12 or 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
