source: FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMCMD.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1IVMCMD ;ALB/SEK,KCL,BRM - DELETE DCD INCOME TESTS ; 12/18/01 1:18pm
2 ;;2.0;INCOME VERIFICATION MATCH;**17,33,49**;21-OCT-94
3 ;
4 ;
5 ;
6EN(IVMMTIEN) ; --
7 ; This routine will process income test deletion requests received
8 ; from the IVM Center.
9 ;
10 ; Input(s):
11 ; IVMMTIEN - pointer to test to be deleted in file 408.31
12 ;
13 ; Output(s):
14 ; Function Value - 1 test deleted
15 ; 0 test not deleted
16 ;
17 ;
18 ; Initialize variables
19 N DFN,IVMERR,IVMLINK,IVMNODE0,IVMDOT,IVMTOT,IVMDONE,IVMLTC
20 S IVMDONE=0
21 ;
22EN1 ; Get zero node of (#408.31)
23 S IVMNODE0=$G(^DGMT(408.31,IVMMTIEN,0))
24 I 'IVMNODE0 Q 1 ; test not found
25 S IVMDOT=$P(IVMNODE0,"^") ; date of test
26 S DFN=$P(IVMNODE0,"^",2)
27 S IVMTOT=$P(IVMNODE0,"^",19) ; type of test
28 S IVMLINK=$P($G(^DGMT(408.31,IVMMTIEN,2)),"^",6)
29 I IVMTOT=1,$D(^DGMT(408.31,"AT",IVMMTIEN)) S IVMLTC=$O(^DGMT(408.31,"AT",IVMMTIEN,""))
30 I IVMTOT=2,IVMLINK Q 0 ; don't delete copay test linked to means test
31 I IVMTOT=1 D I $D(IVMERR) Q 0 ;if MT linked, delete linked test
32 .D:IVMLINK DELETE(IVMLINK,DFN,IVMDOT) ; delete copay test
33 .D:$G(IVMLTC) DELETE(IVMLTC,DFN,IVMDOT) ; delete LTC test
34 ;
35 D DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
36 Q IVMDONE
37 ;
38DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT
39 ;
40 ; Handle LTC test deletion if there is an associated Means Test
41 I $P($G(^DGMT(408.31,+IVMMTIEN,0)),"^",19)=4,+$P($G(^DGMT(408.31,+IVMMTIEN,2)),"^",8) D DEL31^IVMCMD1(IVMMTIEN) Q
42 ;
43 ; Set DGMTP prior to delete
44 S DGMTACT="DEL",DGMTI=IVMMTIEN D PRIOR^DGMTEVT
45 ;
46 ; Get Income Relation IEN array (DGINR) and
47 ; Individual Annual Income IEN array (DGINC)
48 D ALL^DGMTU21(DFN,"VSC",IVMDOT,"IR",IVMMTIEN)
49 ;
50 ;
51DEL22 ; Delete veteran, spouse, and dependent entries from the
52 ; Income Relation (#408.22) file:
53 ; - Veteran (#408.22) record
54 S DA=$G(DGINR("V")) D
55 .Q:'DA
56 .S DIK="^DGMT(408.22,"
57 .D ^DIK
58 ;
59 ; - Spouse (#408.22) record
60 S DA=$G(DGINR("S")) D
61 .Q:'DA
62 .S DIK="^DGMT(408.22,"
63 .D ^DIK
64 ;
65 ; - All dependent children (#408.22) records
66 S IVMDEP=0
67 F S IVMDEP=$O(DGINR("C",IVMDEP)) Q:'IVMDEP D
68 .S DA=$G(DGINR("C",IVMDEP))
69 .S DIK="^DGMT(408.22,"
70 .D ^DIK
71 ;
72 ;
73DEL21 ; Delete veteran, spouse, and dependent entries from
74 ; Individual Annual Income (#408.21) file:
75 ; - Veteran (#408.21) record
76 S DA=$G(DGINC("V")) D
77 .Q:'DA
78 .S DIK="^DGMT(408.21,"
79 .D ^DIK
80 ;
81 ; - Spouse (#408.21) record
82 S DA=$G(DGINC("S")) D
83 .Q:'DA
84 .S DIK="^DGMT(408.21,"
85 .D ^DIK
86 ;
87 ; - All dependent children (#408.21) records
88 S IVMDEP=0
89 F S IVMDEP=$O(DGINC("C",IVMDEP)) Q:'IVMDEP D
90 .S DA=$G(DGINC("C",IVMDEP))
91 .S DIK="^DGMT(408.21,"
92 .D ^DIK
93 ;
94 ;
95 ; Logic for (#408.12/#408.1275) & (#408.13) file entries
96 D SETUPAR
97 ;
98 ; Look for IVM/DCD Patient Realtion (#408.12) file entries.
99 ; If no entries in "AIVM" x-ref, no dependent changes required.
100 S IVM12="" F S IVM12=$O(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12)) Q:'IVM12 D Q:$D(IVMERR)
101 .; - if can't find entry in (#408.12), set IVMERR
102 .I $G(^DGPR(408.12,+IVM12,0))']"" D Q
103 ..S IVMERR="" Q
104 .;
105 .; - if only one record exists in (#408.1275) mult., then only one 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),";") I $G(^DGPR(408.13,+IVM13,0))']"" D Q
110 ...S IVMERR="" Q
111 ..;
112 ..; -- delete (#408.12) & (#408.13) records for IVM/DCD dependent
113 ..S DA=IVM12,DIK="^DGPR(408.12," D ^DIK K DA,DIK
114 ..S DA=IVM13,DIK="^DGPR(408.13," D ^DIK K DA,DIK
115 ..Q
116 .;
117 .;
118 .; Delete (#408.1275) record for IVM/DCD dependent and
119 .; change demo data in (#408.12) & (#408.13) back to VAMC values.
120 .; OR, Delete (#408.1275) record for inactivated VAMC dependent.
121 .S IVM121="",IVM121=$O(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))
122 .; - if can't find entry in (#408.1275), set IVMERR
123 .I $G(^DGPR(408.12,+IVM12,"E",+IVM121,0))']"" D Q
124 ..S IVMERR="" Q
125 .;
126 .S IVMVAMCA=$P($G(^DGPR(408.12,+IVM12,"E",+IVM121,0)),"^",2) ; dependent active?
127 .S DA(1)=IVM12,DA=IVM121,DIK="^DGPR(408.12,"_DA(1)_",""E"","
128 .D ^DIK K DA(1),DA,DIK
129 .;
130 .; - quit if inactivated VAMC dependent
131 .Q:'IVMVAMCA
132 .;
133 .; - get pointer to Income Person (#408.13) file
134 .S IVM13=+$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";")
135 .;
136 .; - change demo data back to original values
137 .D DEMO
138 .Q
139 ;
140 ; Complete deletion of income test
141 D EN^IVMCMD1
142 ;
143ENQ Q
144 ;
145 ;
146DEMO ; Change demographic data in (#408.12) & (#408.13) files
147 ; back to original VAMC values.
148 ;
149 ; Input(s):
150 ; IVM12 - as IEN of (#408.12) file
151 ; IVM13 - as IEN of (#408.13) file
152 ; IVMMTIEN - as IEN of (#408.31) file
153 ;
154 ; Output(s): None
155 ;
156 ; NOTE: File (#408.13) fields were added to (#408.41) file before
157 ; file (#408.12) field.
158 ;
159 K DR S IVM41=0
160 F S IVM41=$O(^DGMT(408.41,"D",IVMMTIEN,IVM41)) Q:'IVM41 D
161 .S IVM411=$G(^DGMT(408.41,+IVM41,0))
162 .Q:$P(IVM411,"^",10)'=IVM13
163 .S IVMOLD=$P(IVM411,"^",5)
164 .S IVMOLD=$S(IVMOLD="":"@",1:IVMOLD)
165 .S IVMFILE=$P(IVMAR1($P(IVM411,"^",2)),";")
166 .S IVMNOD=$P(IVMAR1($P(IVM411,"^",2)),";",2)
167 .I IVMFILE=408.13 S DA=IVM13,DIE="^DGPR(408.13,"
168 .I IVMFILE=408.12 S DA=IVM12,DIE="^DGPR(408.12,"
169 .S DR=IVMNOD_"////^S X=IVMOLD"
170 .D ^DIE K DA,DR,DIE
171 Q
172 ;
173 ;
174SETUPAR ; Create array IVMAR1() where
175 ; 1) Subscript is MT Changes Type (#408.42) file node where type of
176 ; change = Name, DOB, SSN, Sex, Relationship.
177 ; 2) 1st piece is (#408.12) or (#408.13) file.
178 ; 3) 2nd piece is (#408.12) or (#408.13) file field number.
179 ;
180 F IVM41=4:1 S IVM411=$P($T(TYPECH+IVM41),";;",2) Q:IVM411="QUIT" D
181 .S IVMAR1($P(IVM411,";"))=$P(IVM411,";",2,3)
182 K IVM41,IVM411
183 Q
184 ;
185DELTYPE(DFN,MTDATE,TYPE) ;
186 ;will delete any primary test for patient=DFN for same income year as
187 ;MTDATE for test of type=TYPE
188 ;
189 Q:'$G(DFN)
190 Q:'$G(MTDATE)
191 Q:'$G(TYPE)
192 N MTNODE,YEAR,RET
193 S YEAR=$E(MTDATE,1,3)_1230.999999
194 D
195 .S MTNODE=$$LST^DGMTU(DFN,YEAR,TYPE)
196 .Q:'+MTNODE
197 .I $E($P(MTNODE,"^",2),1,3)'=$E(YEAR,1,3) Q
198 .;don't want to delete auto-created Rx copay tests -they are deleted by
199 .; deleting the MT that they are based on
200 .I TYPE=2,+$P($G(^DGMT(408.31,+MTNODE,2)),"^",6) Q
201 .I $P(MTNODE,"^",5),$P(MTNODE,"^",5)'=1 I $$EN(+MTNODE) D
202 ..;
203 ..S RET=$$LST^DGMTU(DFN,DT,IVMTYPE)
204 ..I $E($P(RET,"^",2),1,3)'=$E(YEAR,1,3) S RET=""
205 ..D ADD^IVMCMB(DFN,IVMTYPE,"DELETE PRMY TEST",$P(MTNODE,"^",2),$P(MTNODE,"^",4),$P(RET,"^",4))
206 Q
207 ;
208TYPECH ; Type of dependent changes (#408.41/#408.42) file
209 ; 1st piece - 408.42 table file node
210 ; 2nd piece - file (408.12/408.13)
211 ; 3rd piece - 408.12/408.13 field
212 ;;16;408.13;.01
213 ;;17;408.13;.03
214 ;;18;408.13;.09
215 ;;19;408.13;.02
216 ;;20;408.12;.02
217 ;;QUIT
218 Q
Note: See TracBrowser for help on using the repository browser.