source: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEMD.m@ 623

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

initial load of WorldVistAEHR
File size: 8.8 KB
Line 
1IVMLDEMD ;ALB/PJR/PHH - IVM DEMOGRAPHIC UPLOAD FILE DATE OF DEATH FIELDS ; 7/20/05 9:22am
2 ;;2.0;INCOME VERIFICATION MATCH;**102,108**; 21-OCT-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6DOD(DFN,IVMDA2,IVMDA1,IVMDA) ; function to upload Date of Death
7 ; fields and return a flag
8 ;
9 ; Input: DFN - as patient IEN
10 ; IVMDA2 - pointer to case record in (#301.5) file
11 ; IVMDA1 - pointer to PID msg in (#301.501) sub-file
12 ; IVMDA - pointer to record in (#301.511) sub-file
13 ;
14 ; Output: IVMFLAG - 1 if a Date of Death Field
15 ; 0 if not a Date of Death field
16 ;
17 ;
18 N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,DODFIELD,DELDATA,CKDEL,DGDAUTO
19 ;
20 ; - initialize flags
21 S IVMFLAG=0
22 ;
23 ; - check for required parameters
24 I '$G(DFN)!('$G(IVMDA))!('$G(IVMDA1))!'($G(IVMDA2)) G DODQ
25 ;
26 ; - get pointer to (#301.92) file from (#301.511) sub-file
27 S IVMPTR=+$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)) G DODQ:'IVMPTR
28 ;
29ASK ;;
30 D CKDEL I CKDEL G DODDEL
31 W ! S DIR("A")="Do you wish to proceed with this action"
32 S DIR("A",1)="You have selected to update a Date of Death field."
33 S DIR("A",2)="All Date of Death Fields will be uploaded."
34 S DIR("?")="Enter 'YES' to continue or 'NO' to abort."
35 S DIR(0)="Y",DIR("B")="NO"
36 D ^DIR K DIR
37 S IVMFLAG=1 G DODQ:'Y
38 W !,"Filing Date of Death fields... "
39 ;
40 ;
41LOOP ; - loop through DOD fields
42 S (DGDAUTO,IVMDODUP)=1
43 F DODFIELD="ZPD09","ZPD31","ZPD32" D
44 .S IVMI=$O(^IVM(301.92,"C",DODFIELD,"")) I IVMI="" Q
45 .S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,"")) Q:IVMJ']"" D
46 ..;
47 ..; - check for data node in (#301.511) sub-file
48 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) Q:'(+IVMNODE)
49 ..I DODFIELD="ZPD31",$P(IVMNODE,"^",2)=""!($P(IVMNODE,"^",2)<1)!($P(IVMNODE,"^",2)>9) S $P(IVMNODE,"^",2)="@"
50 ..I DODFIELD'="ZPD31",$P(IVMNODE,"^",2)=""!($E($P(IVMNODE,"^",2),1,7)'?1.7N) S $P(IVMNODE,"^",2)="@"
51 ..;
52 ..; load Date of Death field rec'd from IVM into DHCP (#2) file
53 ..D UPLOAD(+DFN,$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),$P(IVMNODE,"^",2)) S IVMFLAG=1
54 ..;
55 ..; - remove entry from (#301.511) sub-file
56 ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
57 ;
58 I IVMFLAG D W "completed.",!
59 .D UPLOAD(+DFN,.355,$S($G(DUZ):DUZ,1:.5))
60 D DISCHRGE^DGDEATH,XFR^DGDEATH
61 K IVMDODUP
62 ;
63 S VALMBCK="R"
64 ;
65 G DODQ
66 ;
67DODDEL ;
68 W ! S DIR("A")="Do you wish to proceed with this action"
69 S DIR("A",1)="You have selected to update a DELETION of a Date of Death field."
70 S DIR("A",2)="All Date of Death Fields will be deleted."
71 S DIR("?")="Enter 'YES' to continue or 'NO' to abort."
72 S DIR(0)="Y",DIR("B")="NO"
73 D ^DIR K DIR
74 S IVMFLAG=1 G DODQ:'Y
75 W !,"Filing Date of Death deletions... "
76 F DODFIELD="ZPD09","ZPD31","ZPD32" D
77 .S IVMI=$O(^IVM(301.92,"C",DODFIELD,"")) I IVMI="" Q
78 .S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,"")) Q:IVMJ']""
79 .;
80 .; - check for data node in (#301.511) sub-file
81 .S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
82 .Q:'(+IVMNODE)
83 .;
84 .; load Date of Death deletion rec'd from IVM into DHCP (#2) file
85 .I DODFIELD="ZPD09" D UPLOAD(+DFN,.351,"@")
86 .;
87 .; - remove entry from (#301.511) sub-file
88 .D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
89 ;
90 I IVMFLAG D W "completed.",!
91 .D UPLOAD(+DFN,.355,.5)
92 ;
93 S VALMBCK="R"
94 ;
95 G DODQ
96CKDEL S CKDEL=0
97 S IVMI=$O(^IVM(301.92,"C","ZPD09","")) I IVMI="" Q
98 S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
99 I IVMJ']"" Q
100 ;
101 ; - check for data node in (#301.511) sub-file
102 S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
103 Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"")
104 ;
105 I $P(IVMNODE,"^",2)="""""" S CKDEL=1
106 Q
107AUTODOD(DFN) ;
108 ; function to automatically upload Date of Death
109 ; fields and return a flag
110 ;
111 ; Input: DFN - as patient IEN
112 ;
113 ; Output: IVMFLAG - 1 if a Date of Death Field
114 ; 0 if not a Date of Death field
115 ;
116 N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,DODFIELD
117 N DELDATA,CKDEL,CKADD,CKDUZ,IVMDA1,IVMDA2,DGDAUTO,IVMENT4
118 ;
119 ; - initialize flags
120 S (IVMFLAG,CKDEL,CKADD,CKDUZ)=0,IVMENT4=999999999
121 ;
122 ; - check for required parameters
123 S IVMDA2=$G(IVM3015)
124 I 'IVMDA2 G DODQ
125 S IVMDA1=$O(^HL(771.3,"B","PID",""))
126 S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
127 I 'IVMDA1 G DODQ
128 ;
129 D CKAUTO I CKDEL D AUTODEL,DEM5,BULL(+^IVM(301.5,IVMDA2,0)) G DODQ
130 I CKADD D CKDUZ,AUTOADD,DEM5 G DODQ
131 G DODQ
132AUTOADD ;
133 S DGDAUTO=1
134 ; - loop through DOD fields
135 F DODFIELD="ZPD09","ZPD31","ZPD32" D
136 .S IVMI=$O(^IVM(301.92,"C",DODFIELD,"")) I IVMI="" Q
137 .S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,"")) Q:IVMJ']"" D
138 ..;
139 ..; - check for data node in (#301.511) sub-file
140 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) Q:'(+IVMNODE)
141 ..I DODFIELD="ZPD31",$P(IVMNODE,"^",2)=""!($P(IVMNODE,"^",2)<1)!($P(IVMNODE,"^",2)>9) S $P(IVMNODE,"^",2)="@"
142 ..I DODFIELD'="ZPD31",$P(IVMNODE,"^",2)=""!($E($P(IVMNODE,"^",2),1,7)'?1.7N) S $P(IVMNODE,"^",2)="@"
143 ..;
144 ..; load Date of Death field rec'd from IVM into DHCP (#2) file
145 ..I DODFIELD'="ZPD09" D UPLOAD(+DFN,$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),$P(IVMNODE,"^",2)) S IVMFLAG=1
146 ..; - remove entry from (#301.511) sub-file
147 ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
148 ;
149 I IVMFLAG D UPLOAD(+DFN,.355,$S(CKDUZ:CKDUZ,1:.5))
150 D CLEAN(IVMDA2)
151 Q
152AUTODEL ;
153 N DFNDOD,DODMPI S DFNDOD=0 I $P($G(^DPT(+DFN,.35)),U)>0 S DFNDOD=1
154 F DODFIELD="ZPD09","ZPD31","ZPD32" D
155 .S IVMI=$O(^IVM(301.92,"C",DODFIELD,"")) I IVMI="" Q
156 .S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,"")) Q:IVMJ']""
157 .; - check for data node in (#301.511) sub-file
158 .S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
159 .Q:'(+IVMNODE)
160 .; load Date of Death deletion rec'd from IVM into DHCP (#2) file
161 .I DODFIELD="ZPD09" I DFNDOD D UPLOAD(+DFN,.351,"@") S DODMPI=$$A31^MPIFA31B(+DFN),IVMFLAG=1
162 .; - remove entry from (#301.511) sub-file
163 .D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
164 ;
165 I IVMFLAG D UPLOAD(+DFN,.355,.5)
166 D CLEAN(IVMDA2)
167 Q
168DEM5 ;
169 I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D
170 .D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up name parameter
171 Q
172CKAUTO S (CKDEL,CKADD)=0
173 S IVMI=$O(^IVM(301.92,"C","ZPD09","")) I IVMI="" Q
174 S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
175 I IVMJ']"" Q
176 ;
177 ; - check for data node in (#301.511) sub-file
178 S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
179 Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"")
180 ;
181 I $P(IVMNODE,"^",2)="""""" S CKDEL=1 Q
182 I $P(IVMNODE,"^",2)=$P($G(^DPT(DFN,.35)),"^",1) S CKADD=1
183 Q
184CKDUZ ; Check to preserve DUZ for "Last Edited By"
185 S IVMI=$O(^IVM(301.92,"C","ZPD32","")) I IVMI="" Q
186 S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
187 I IVMJ']"" Q
188 ;
189 ; - check for data node in (#301.511) sub-file
190 S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
191 Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"")
192 ;
193 I $P(IVMNODE,"^",2)=$P($G(^DPT(DFN,.35)),"^",4) D
194 .S CKDUZ=$P($G(^DPT(DFN,.35)),"^",5)
195 Q
196UPLOAD(DFN,IVMFIELD,IVMVALUE) ; - file Date of Death fields received from IVM
197 ; Input: DFN - as patient IEN
198 ; IVMFIELD - as the field number to be updated
199 ; IVMVALUE - as the value of the field
200 ;
201 ; Output: None
202 ;
203 N DA,DIE,DR
204 S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
205 D ^DIE
206 Q
207 ;
208DODQ ; - return --> 1 if uploadable field is a Date of Death field
209 ; --> 0 if nothing uploadable
210 ;
211 I IVMFLAG D RESET^IVMLDEMU
212 Q IVMFLAG
213 ;
214CLEAN(IVMI) ;
215 ; Remove any Date of Death related entries from IVM UPLOAD DEM
216 N IVMJ,IVMN,IVM92,OTHFLG
217 S IVMJ=0 F S IVMJ=$O(^IVM(301.5,"ASEG","PID",IVMI,IVMJ)) Q:'IVMJ D
218 .I '$D(^IVM(301.5,IVMI,"IN",IVMJ)) D REMASEG(IVMI,IVMJ) Q
219 .S (OTHFLG,IVMN)=0 F S IVMN=$O(^IVM(301.5,IVMI,"IN",IVMJ,"DEM",IVMN)) Q:'IVMN D
220 ..S IVM92=$P(^IVM(301.5,IVMI,"IN",IVMJ,"DEM",IVMN,0),U)
221 ..I "^15^36^37^"[(U_IVM92_U) D REM511(IVMI,IVMJ,IVMN)
222 ..I "^15^36^37^"'[(U_IVM92_U) S OTHFLG=1
223 .I 'OTHFLG D REM501(IVMI,IVMJ)
224 Q
225 ;
226REM501(IVMI,IVMJ) ;
227 ; Delete 301.501 entry to remove from ASEG x-ref
228 N DA,DIE,DR
229 S DA=IVMJ,DA(1)=IVMI
230 S DIE="^IVM(301.5,"_DA(1)_",""IN"","
231 S DR=".02////@" D ^DIE
232 Q
233 ;
234REM511(IVMI,IVMJ,IVMN) ;
235 ; Delete 301.511 entry to remove from IVM UPLOAD DEM
236 N DA,DIK
237 S DA(1)=IVMJ,DA(2)=IVMI,DA=IVMN
238 S DIK="^IVM(301.5,"_DA(2)_",""IN"","_DA(1)_",""DEM"","
239 D ^DIK
240 Q
241 ;
242REMASEG(IVMI,IVMJ) ;
243 ; Delete invalid ASEG x-ref entries
244 K ^IVM(301.5,"ASEG","PID",IVMI,IVMJ)
245 Q
246BULL(DFN) ; Date of Death Deletion Bulletin
247 I '$D(^DPT(DFN,0)) Q
248 I '(+$G(^DPT(DFN,.35))) Q
249 ;
250 N DGDEATH,DGB,DGPCMM,XMSUB,X
251 S DGDEATH=+$G(^DPT(DFN,.35)),XMSUB="Patient Death has been Deleted",DGCT=0
252 D ^DGPATV
253 D LINE^DGDEATH("The date of death for the following patient has been deleted.")
254 D LINE^DGDEATH("")
255 D DEMOG^DGDEATH
256 D LINE^DGDEATH("")
257 S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
258 S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
259 S DGB=1 D ^DGBUL S X=DGDEATH
260 K DGCT,DGDEATH D KILL^DGPATV
261 ;
262 Q
Note: See TracBrowser for help on using the repository browser.