source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG53358D.m@ 1602

Last change on this file since 1602 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1DG53358D ;ALB/AEG,GN DG*5.3*358 DELETE INCOME TESTS ; 12/17/03 3:06pm
2 ;;5.3;REGISTRATION;**358,558**;5-1-2001
3 ;
4 ;This is a modified version of IVMCMD in that it calls a modified
5 ;version of IVMCMD1 called DG53358C which only deletes the
6 ;records from the Annual Means Test(#408.31) file. It does not open
7 ;a case record in the IVM Patient (#301.5)file, does not send 'delete'
8 ;bulletin/notification to local mail group, does not call the means
9 ;test event driver and does not call DGMTR.
10 ;
11 ;DG*53*558 - re-deploy with this patch
12 ;
13EN(IVMMTIEN) ; --
14 ; This routine will process income test deletion requests received
15 ; from the IVM Center.
16 ;
17 ; Input(s):
18 ; IVMMTIEN - pointer to test to be deleted in file 408.31
19 ;
20 ; Output(s):
21 ; Function Value - 1 test deleted
22 ; 0 test not deleted
23 ;
24 ;
25 ; Initialize variables
26 N DFN,IVMERR,IVMLINK,IVMNODE0,IVMDOT,IVMTOT,IVMDONE
27 S IVMDONE=0
28 ;
29EN1 ; Get zero node of (#408.31)
30 S IVMNODE0=$G(^DGMT(408.31,IVMMTIEN,0))
31 I 'IVMNODE0 Q 1 ; test not found
32 S IVMDOT=$P(IVMNODE0,"^") ; date of test
33 S DFN=$P(IVMNODE0,"^",2)
34 S IVMTOT=$P(IVMNODE0,"^",19) ; type of test
35 S IVMLINK=$P($G(^DGMT(408.31,IVMMTIEN,2)),"^",6)
36 ;don't delete copay test linked to valid means test
37 I IVMTOT=2,IVMLINK,$D(^DGMT(408.31,IVMLINK,0)) Q 0
38 I IVMTOT=1,IVMLINK D I $D(IVMERR) Q 0 ;I MT linkd to copay delete both
39 .D DELETE(IVMLINK,DFN,IVMDOT) ; delete copay
40 D DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
41 Q IVMDONE
42 ;
43DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
44 ;
45 ; Get Income Relation IEN array (DGINR) and
46 ; Individual Annual Income IEN array (DGINC)
47 D ALL^DGMTU21(DFN,"VSC",IVMDOT,"IR",IVMMTIEN)
48 ;
49 ;
50DEL22 ; Delete veteran, spouse, and dependent entries from the
51 ; Income Relation (#408.22) file:
52 ; - Veteran (#408.22) record
53 S DA=$G(DGINR("V")) D
54 .Q:'DA
55 .S DIK="^DGMT(408.22,"
56 .D ^DIK
57 ;
58 ; - Spouse (#408.22) record
59 S DA=$G(DGINR("S")) D
60 .Q:'DA
61 .S DIK="^DGMT(408.22,"
62 .D ^DIK
63 ;
64 ; - All dependent children (#408.22) records
65 S IVMDEP=0
66 F S IVMDEP=$O(DGINR("C",IVMDEP)) Q:'IVMDEP D
67 .S DA=$G(DGINR("C",IVMDEP))
68 .S DIK="^DGMT(408.22,"
69 .D ^DIK
70 ;
71 ;
72DEL21 ; Delete veteran, spouse, and dependent entries from
73 ; Individual Annual Income (#408.21) file:
74 ; - Veteran (#408.21) record
75 S DA=$G(DGINC("V")) D
76 .Q:'DA
77 .S DIK="^DGMT(408.21,"
78 .D ^DIK
79 ;
80 ; - Spouse (#408.21) record
81 S DA=$G(DGINC("S")) D
82 .Q:'DA
83 .S DIK="^DGMT(408.21,"
84 .D ^DIK
85 ;
86 ; - All dependent children (#408.21) records
87 S IVMDEP=0
88 F S IVMDEP=$O(DGINC("C",IVMDEP)) Q:'IVMDEP D
89 .S DA=$G(DGINC("C",IVMDEP))
90 .S DIK="^DGMT(408.21,"
91 .D ^DIK
92 ;
93 ;
94 ; Logic for (#408.12/#408.1275) & (#408.13) file entries
95 D SETUPAR
96 ;
97 ; Look for IVM/DCD Patient Realtion (#408.12) file entries.
98 ; If no entries in "AIVM" x-ref, no dependent changes required.
99 S IVM12="" F S IVM12=$O(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12)) Q:'IVM12 D Q:$D(IVMERR)
100 .; -- if can't find entry in (#408.12), set IVMERR
101 .I $G(^DGPR(408.12,+IVM12,0))']"" D Q
102 ..S IVMERR="" Q
103 .;
104 .; - if only one record exists in (#408.1275) mult., then only one
105 .;IVM/DCD dependent to delete
106 .I $P($G(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1 D Q
107 ..;
108 ..; -- if can't find entry in (#408.13), set IVMERR
109 ..S IVM13=$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";")
110 ..I $G(^DGPR(408.13,+IVM13,0))']"" D Q
111 ...S IVMERR="" Q
112 ..;
113 ..; -- delete (#408.12) & (#408.13) records for IVM/DCD dependent
114 ..S DA=IVM12,DIK="^DGPR(408.12," D ^DIK K DA,DIK
115 ..S DA=IVM13,DIK="^DGPR(408.13," D ^DIK K DA,DIK
116 ..Q
117 .;
118 .;
119 .; Delete (#408.1275) record for IVM/DCD dependent and
120 .; change demo data in (#408.12) & (#408.13) back to VAMC values.
121 .; OR, Delete (#408.1275) record for inactivated VAMC dependent.
122 .S IVM121="",IVM121=$O(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))
123 .; - if can't find entry in (#408.1275), set IVMERR
124 .I $G(^DGPR(408.12,+IVM12,"E",+IVM121,0))']"" D Q
125 ..S IVMERR="" Q
126 .;
127 .S IVMVAMCA=$P($G(^DGPR(408.12,+IVM12,"E",+IVM121,0)),"^",2)
128 .;dependent active?
129 .;
130 .; - If active, inactivate dependant
131 .I IVMVAMCA D
132 ..S DR=".02////0",DA=+IVM121,DA(1)=0
133 ..S DIE="^DGPR(408.12,"_+IVM12_",""E"","
134 ..D ^DIE S IVMVAMCA=0 Q
135 .;
136 .S DA(1)=IVM12,DA=IVM121,DIK="^DGPR(408.12,"_DA(1)_",""E"","
137 .D ^DIK K DA(1),DA,DIK
138 .;
139 .Q
140 ;
141 ; Complete deletion of income test
142 D EN^DG53358C
143 ;
144ENQ Q
145 ;
146 ;
147SETUPAR ; Create array IVMAR1() where
148 ; 1) Subscript is MT Changes Type (#408.42) file node where type of
149 ; change = Name, DOB, SSN, Sex, Relationship.
150 ; 2) 1st piece is (#408.12) or (#408.13) file.
151 ; 3) 2nd piece is (#408.12) or (#408.13) file field number.
152 ;
153 F IVM41=4:1 S IVM411=$P($T(TYPECH+IVM41),";;",2) Q:IVM411="QUIT" D
154 .S IVMAR1($P(IVM411,";"))=$P(IVM411,";",2,3)
155 K IVM41,IVM411
156 Q
157 ;
158DELTYPE(DFN,MTDATE,TYPE) ;
159 ;will delete any primary test for patient=DFN for same income year as
160 ;MTDATE for test of type=TYPE
161 ;
162 Q:'$G(DFN)
163 Q:'$G(MTDATE)
164 Q:'$G(TYPE)
165 N MTNODE,YEAR,RET
166 S YEAR=$E(MTDATE,1,3)_1230.999999
167 D
168 .S MTNODE=$$LST^DGMTU(DFN,YEAR,TYPE)
169 .Q:'+MTNODE
170 .I $E($P(MTNODE,"^",2),1,3)'=$E(YEAR,1,3) Q
171 .;don't want to delete auto-created Rx copay tests -they are deleted by
172 .; deleting the MT that they are based on
173 .I TYPE=2,+$P($G(^DGMT(408.31,+MTNODE,2)),"^",6) Q
174 .I $P(MTNODE,"^",5),$P(MTNODE,"^",5)'=1 I $$EN(+MTNODE) D
175 ..;
176 ..S RET=$$LST^DGMTU(DFN,DT,IVMTYPE)
177 ..I $E($P(RET,"^",2),1,3)'=$E(YEAR,1,3) S RET=""
178 ..D ADD^IVMCMB(DFN,IVMTYPE,"DELETE PRMYTEST",$P(MTNODE,"^",2),$P(MTNODE,"^",4),$P(RET,"^",4))
179 Q
180 ;
181TYPECH ; Type of dependent changes (#408.41/#408.42) file
182 ; 1st piece - 408.42 table file node
183 ; 2nd piece - file (408.12/408.13)
184 ; 3rd piece - 408.12/408.13 field
185 ;;16;408.13;.01
186 ;;17;408.13;.03
187 ;;18;408.13;.09
188 ;;19;408.13;.02
189 ;;20;408.12;.02
190 ;;QUIT
191 Q
Note: See TracBrowser for help on using the repository browser.