source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUPD51.m

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1RORUPD51 ;HCIOFO/SG - UPDATE PATIENT'S DEMOGRAPHIC DATA (1) ; 7/6/06 11:15am
2 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
3 ;
4 Q
5 ;
6 ;***** MARKS REGISTRIES (UPDATE DEMOGRAPHICS)
7 ;
8 ; PTIEN Patient IEN
9 ; [DOD] Date of death
10 ;
11 ; Return Values:
12 ; <0 Error code
13 ; 0 Ok
14 ;
15MARKREGS(PTIEN,DOD) ;
16 N ACTIVE,ECNT,I,IENS,RC,RI,TMP
17 N RORBUF,RORFDA,RORMSG,RORSRC
18 ;--- Compile a list of associated registries
19 D FIND^DIC(798,,"@","QUX",PTIEN,,"B",,,"RORBUF","RORMSG")
20 Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,PTIEN,798)
21 ;--- Mark patient records of the registries
22 S RI="",ECNT=0
23 F S RI=$O(RORBUF("DILIST",2,RI)) Q:RI="" D L -^RORDATA(798,+IENS)
24 . S IENS=RORBUF("DILIST",2,RI)_","
25 . K RORFDA,RORSRC
26 . ;--- Try to lock the record; if this fails, continue anyway
27 . L +^RORDATA(798,+IENS):3
28 . ;--- Load the field values
29 . D GETS^DIQ(798,IENS,"4;8","EI","RORSRC","RORMSG")
30 . I $G(DIERR) D S ECNT=ECNT+1 Q
31 . . S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798,IENS)
32 . S ACTIVE=+$G(RORSRC(798,IENS,8,"E"))
33 . ;--- Do not mark again if already marked
34 . I '$G(RORSRC(798,IENS,4,"I")) S RC=0 D Q:RC<0
35 . . ;--- Mark only active records
36 . . S:ACTIVE RORFDA(798,IENS,4)=1
37 . ;--- Update registry data record
38 . I $D(RORFDA)>1 S RC=0 D Q:RC<0
39 . . D FILE^DIE(,"RORFDA","RORMSG")
40 . . I $G(DIERR) D S ECNT=ECNT+1
41 . . . S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798,IENS)
42 Q $S(ECNT>0:-9,1:0)
43 ;
44 ;***** PROCESSES THE MERGED PATIENT RECORD
45 ;
46 ; DFN IEN of the merged record (medrged from)
47 ; NEWDFN New patient IEN (merged to)
48 ;
49 ; Return values:
50 ; <0 Error code
51 ; 0 Ok
52 ;
53MERGE(DFN,NEWDFN) ;
54 N DA,DIK,DTNEW,DTOLD,IEN,IENS,IR,PTIEN,REGIEN,REGLST,RORBUF,RORFDA,RORMSG,TMP
55 D LOG^RORERR(-111,,,DFN,NEWDFN)
56 ;=== Get the lists of registry records associated with the
57 ;=== merged from ("from") and merged to ("to") patient data
58 F PTIEN=DFN,NEWDFN D Q:RC<0
59 . K RORBUF,RORMSG
60 . D FIND^DIC(798,,"@;.02I;1I","QUX",PTIEN,,"B",,,"RORBUF","RORMSG")
61 . I $G(DIERR) S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798) Q
62 . S IR=0
63 . F S IR=$O(RORBUF("DILIST",2,IR)) Q:IR'>0 D Q:RC<0
64 . . S IEN=+RORBUF("DILIST",2,IR)
65 . . S REGIEN=+$G(RORBUF("DILIST","ID",IR,.02))
66 . . I REGIEN'>0 S RC=$$ERROR^RORERR(-95,,,PTIEN,798,IEN_",",.02) Q
67 . . S TMP=+$G(RORBUF("DILIST","ID",IR,1))
68 . . I TMP'>0 S RC=$$ERROR^RORERR(-95,,,PTIEN,798,IEN_",",1) Q
69 . . S REGLST(PTIEN,REGIEN)=IEN_U_TMP
70 Q:RC<0 RC
71 ;=== Compare the "from" and "to" registry records
72 S REGIEN=0
73 F S REGIEN=$O(REGLST(DFN,REGIEN)) Q:REGIEN'>0 D
74 . K RORFDA,RORMSG S RC=0
75 . S DTOLD=+$P(REGLST(DFN,REGIEN),U,2)
76 . S DTNEW=+$P($G(REGLST(NEWDFN,REGIEN)),U,2)
77 . I (DTNEW'>0)!(DTOLD<DTNEW) D Q:RC<0
78 . . ;--- Make sure that the "to" patient has a record
79 . . ;--- in the ROR PATIENT file.
80 . . S RC=$$ADDPDATA^RORUPD50(NEWDFN) Q:RC<0
81 . . ;--- Replace the .01 value in the "from" registry record with
82 . . ; the new patient pointer since there is either no other
83 . . ;--- record for this patient or it is newer than the "from" one.
84 . . S IENS=+$P(REGLST(DFN,REGIEN),U)_","
85 . . S RORFDA(798,IENS,.01)=NEWDFN
86 . . D FILE^DIE(,"RORFDA","RORMSG")
87 . . I $G(DIERR) S RC=$$DBS^RORERR("RORMSG",-9,,DFN,798,IENS) Q
88 . . ;--- Delete the "to" registry record. It was created after
89 . . ;--- the original ("from") one and we should keep the latter.
90 . . S DA=+$P($G(REGLST(NEWDFN,REGIEN)),U)
91 . . I DA>0 S DIK=$$ROOT^DILFD(798) D ^DIK
92 . E D
93 . . ;--- Delete the "from" registry record since
94 . . ;--- the "to" record is actually older
95 . . S DIK=$$ROOT^DILFD(798),DA=+$P(REGLST(DFN,REGIEN),U) D ^DIK
96 . ;--- Indicate successful merge
97 . K REGLST(DFN,REGIEN)
98 ;=== Done
99 Q 0
100 ;
101 ;***** SCANS PATIENTS AND UPDATES DEMOGRAPHIC DATA (IF NECESSARY)
102 ;
103 ; .REGLST Reference to a local array containing
104 ; registry names as subscripts
105 ;
106 ; Return Values:
107 ; <0 Error code
108 ; 0 Ok
109 ;
110UPDDEM(REGLST) ;
111 N CNT,IR,PTIEN,RC,REGIEN,REGNAME,ROOT,SCR,UPD,UPDCNT
112 N RORLOR,RORLST,RORMSG
113 S ROOT=$$ROOT^DILFD(798,,1)
114 ;--- Compile a list of registry internal entry numbers
115 S REGNAME="",RC=0
116 F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:RC<0
117 . S RC=+$G(REGLST(REGNAME))
118 . S:RC'>0 RC=$$REGIEN^RORUTL02(REGNAME)
119 . S:RC>0 RORLOR(+RC)=""
120 Q:RC<0 RC
121 ;--- Loop through the patients of the registries
122 S PTIEN="",(CNT,RC)=0
123 F S PTIEN=$O(@ROOT@("B",PTIEN)) Q:PTIEN="" D Q:RC<0
124 . ;--- Check if task stop has been requested
125 . I $D(ZTQUEUED),$$S^%ZTLOAD D Q
126 . . S RC=$$ERROR^RORERR(-42)
127 . S CNT=CNT+1
128 . I $G(RORPARM("DEBUG"))>1 W:$E($G(IOST),1,2)="C-" *13,CNT
129 . ;--- Check for "stray" items in the cross-reference
130 . S IR=""
131 . F S IR=$O(@ROOT@("B",PTIEN,IR)) Q:IR="" D
132 . . K:$P($G(@ROOT@(IR,0)),U)'>0 @ROOT@("B",PTIEN,IR)
133 . Q:$D(@ROOT@("B",PTIEN))<10
134 . ;--- Check for a merged patient record
135 . S RC=$$MERGED^RORUTL18(PTIEN)
136 . I RC S:RC>0 RC=$$MERGE(PTIEN,RC) S RC=0 Q
137 . ;--- Load a list of patient's registry records
138 . S SCR="S Y=+$P($G(^(0)),U,2) I Y,$D(RORLOR(Y))"
139 . D FIND^DIC(798,,"@;.02I;3I;8E","QUX",PTIEN,,"B",SCR,,"RORLST","RORMSG")
140 . I $G(DIERR) D Q
141 . . S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798)
142 . ;--- Demographic data should be checked only if at least one of
143 . ;--- the registry records of the patient is active.
144 . S IR="",UPDCNT=0
145 . F S IR=$O(RORLST("DILIST","ID",IR)) Q:IR="" D
146 . . S UPD=+$G(RORLST("DILIST","ID",IR,8))
147 . . S REGIEN=+$G(RORLST("DILIST","ID",IR,.02))
148 . . S TMP=+$G(RORLST("DILIST","ID",IR,3)) ; STATUS
149 . . S CNT(REGIEN,TMP)=$G(CNT(REGIEN,TMP))+1
150 . . S:UPD UPDCNT=UPDCNT+1
151 . S:UPDCNT RC=$$UPDPTDEM(PTIEN)
152 D:RC'<0 UPDRCNT(.CNT)
153 ;---
154 Q $S(RC<0:RC,1:0)
155 ;
156 ;***** UPDATES DEMOGRAPHIC DATA OF THE PATIENT (IF NECESSARY)
157 ;
158 ; PTIEN Patient IEN
159 ;
160 ; Return Values:
161 ; <0 Error code
162 ; 0 Ok
163 ;
164UPDPTDEM(PTIEN) ;
165 N CF,DOD,IENS,RC,RORMSG,RORPAT
166 S IENS=PTIEN_",",CF=0
167 ;--- Try to lock the record of the ROR PATIENT file
168 L +^RORDATA(798.4,PTIEN):3
169 E Q $$ERROR^RORERR(-11,,,PTIEN,"file #798.4")
170 D
171 . ;--- Compare demographic data
172 . S RC=$$PATDATA^RORUPD52(IENS,.RORPAT,IENS,.DOD) Q:RC<0
173 . S:RC CF=1
174 . ;--- Mark registry records of the patient
175 . I CF S RC=$$MARKREGS(PTIEN,$G(DOD)) Q:RC<0
176 . ;--- Update demographic data
177 . I CF,$D(RORPAT)>1 S RC=0 D Q:RC<0
178 . . D FILE^DIE(,"RORPAT","RORMSG") Q:'$G(DIERR)
179 . . S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798.4)
180 ;
181 L -^RORDATA(798.4,PTIEN)
182 Q 0
183 ;
184 ;***** UPDATES RECORD COUNTERS IN THE 'ROR REGISTRY PARAMETERS' FILE
185 ;
186 ; .CNT( Reference to a local array containg registry
187 ; record counters
188 ; Registry#,
189 ; 0) Number of confirmed records
190 ; 4) Number of pending records
191 ;
192UPDRCNT(CNT) ;
193 N IENS,RC,REGIEN,RORFDA,RORMSG
194 S REGIEN=0
195 F S REGIEN=$O(CNT(REGIEN)) Q:REGIEN="" D
196 . S IENS=REGIEN_","
197 . S RORFDA(798.1,IENS,19.1)=$G(CNT(REGIEN,0))
198 . S RORFDA(798.1,IENS,19.2)=$G(CNT(REGIEN,4))
199 . D FILE^DIE("K","RORFDA","RORMSG")
200 . I $G(DIERR) D Q
201 . . S RC=$$DBS^RORERR("RORMSG",-9,,798.1,IENS)
202 Q
Note: See TracBrowser for help on using the repository browser.