source: FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDPICK.m@ 632

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

initial load of FOIAVistA 6/30/08 version

File size: 8.5 KB
Line 
1XDRDPICK ;SF-IRMFO.SEA/JLI - SELECT A PAIR OF POTENTIAL DUPLICATES AND VIEW ;07/27/2000 09:56
2 ;;7.3;TOOLKIT;**23,47**;Apr 25, 1995
3 ;;
4EN ;
5 N XDRFL,CMORS1,CMORS2,D0,DA,DIC,DIE,DIR,ICNT,ICNT1,JCNT,LCNT,NCNT,PNCT,TMPGLA,TMPGLB,XDRDA,XDRFILN,XDRGLB,Y,PRIFILE
6 ; D EN^XDRVCHEK
7 S XDRFL=$$FILE() Q:XDRFL'>0 S PRIFILE=XDRFL,XDRGLB=$P(^DIC(XDRFL,0,"GL"),U,2),XDRFILN=$P(^DIC(XDRFL,0),U)
8LOOP ;
9 W !!!,"At the following prompt select a POTENTIAL DUPLICATE ENTRY. If a selection"
10 W !,"is not made, you will be given a chance to select from a list if you"
11 W !,"want to. Otherwise, you will be returned to the menu system."
12 W !
13 S Y=$$LOOKUP^XDRDEDT(XDRFL)
14 S XDRDA=+Y I Y>0 D SHOW G LOOP
15 S DIR(0)="Y"
16 S DIR("A")="Do you want to select from a list of potential duplicates"
17 S DIR("B")="YES"
18 D ^DIR K DIR Q:Y'>0
19 S TMPGLB=$NA(^TMP("XDRDPICK",$J)),TMPGLA=$NA(^TMP("XDRDPICA",$J))
20 K @TMPGLB,@TMPGLA
21 D ASK
22 I XDRDA>0 G LOOP
23 K PCNT
24 Q
25 ;
26GETLIST ;
27 I XDRGLB="DPT(",$O(^DPT("ACMORS",0))>0 D CMORS Q
28 N FLG
29 F ICNT=ICNT:0 S ICNT=$O(^VA(15,ICNT)) Q:ICNT'>0 S X=^(ICNT,0) D Q:'(NCNT#4)&(NCNT>0)&FLG
30 . S FLG=1 ;This flag is when NCNT is set from previous call and STATUS is not "P" the first time- - so loop will not quit with (NCNT#4)
31 . I $P(X,U,3)'="P" S:PCNT=NCNT FLG=0 Q
32 . I $P($P(X,U),";",2)'=XDRGLB Q
33 . S NCNT=NCNT+1,X1=+$P(X,U),X2=+$P(X,U,2)
34 . I '($D(@(U_XDRGLB_X1_",0)"))#2)!'($D(@(U_XDRGLB_X2_",0)"))#2) S NCNT=NCNT-1 Q
35 . S @TMPGLB@(NCNT)=ICNT_U_X1_U_X2
36 . S @TMPGLB@(NCNT,1)=@(U_XDRGLB_X1_",0)")
37 . S @TMPGLB@(NCNT,2)=@(U_XDRGLB_X2_",0)")
38 Q
39 ;
40ASK ;
41 S NCNT=0,ICNT=0,ICNT1=0,JCNT=0,XDRDA=0,PCNT=0
42 F D D CHEK Q:XDRDA'=0 Q:JCNT'>0
43 . D GETLIST
44 . S PCNT=NCNT
45 . F JCNT=JCNT:0 S JCNT=$O(@TMPGLB@(JCNT)) Q:JCNT'>0 D Q:'(JCNT#4)
46 . . W !!!,$J(JCNT,5),". ",@TMPGLB@(JCNT,1)
47 . . W !,?8,@TMPGLB@(JCNT,2)
48 I XDRDA>0 S XDRDA=+@TMPGLB@(XDRDA) D SHOW
49 Q
50 ;
51CHEK ;
52 W !
53 I JCNT'>0 S DIR(0)="N"
54 E S DIR(0)="NO",DIR("A",1)="Enter Return to continue listing or"
55 S DIR("A")="Select the desired entry by number"
56 S DIR(0)=DIR(0)_"^1:"_NCNT
57 D ^DIR K DIR
58 I Y>0 S XDRDA=+Y
59 I $D(DUOUT)!$D(DTOUT) S XDRDA=-1 K DTOUT,DUOUT
60 K DIRUT
61 Q
62 ;
63SHOW ;
64 ;L +^VA(15,+XDRDA,0):30 I '$T G BUSY
65 ;I $P(^VA(15,+XDRDA,0),U,3)'="P" L -^VA(15,+XDRDA,0) G BUSY ; NOT AVAILABLE
66 ;N XDRXX S XDRXX(15,(+XDRDA)_",",.03)="X"
67 ;D FILE^DIE("","XDRXX")
68 ;L -^VA(15,+XDRDA,0)
69 I '$D(XDRGLB) N XDRGLB S XDRGLB=$P($P(^VA(15,XDRDA,0),U),";",2)
70 I $D(@(XDRGLB_(+^VA(15,XDRDA,0))_",-9)"))!$D(@(XDRGLB_(+$P(^VA(15,XDRDA,0),U,2))_",-9)")) W !,$C(7),"One of these entries has already been merged. Pick another pair.",!! D RESET(XDRDA) Q
71 S XQAID=""
72 S X=^VA(15,+XDRDA,0)
73 S X1=+X,X2=+$P(X,U,2)
74 I $$COUNT^XDRRMRG2(XDRFL,X1,X2)>1 S X1=X2,X2=+X
75 S XQADATA=XDRDA_U_X1_";"_X2_U_"PRIMARY"_U_XDRFL
76 D ^XDRRMRG1
77 S DA=$$FIND1^DIC(15.02,","_XDRDA_",","X","PRIMARY")
78 I DA>0 D
79 . S X=$P(^VA(15,XDRDA,0),U,3)
80 . I X="N"!(X="V") Q
81 . S X=^VA(15,XDRDA,2,DA,0)
82 . I $P(X,U,2)="V" D
83 . . S DR=".03///X;.1///"_DT_";"
84 . . S DIE="^VA(15,",DA=XDRDA D ^DIE K DIE,DR
85 . . D SETUP^XDRRMRG1(XDRDA)
86 . . D CHEKVER^XDRRMRG1
87 Q
88 ;
89BUSY ;
90 W !!,$C(7),"Record is being processed by someone else.",!!
91 Q
92 ;
93FILE() ;
94 N X
95 S X=0
96 F I=0:0 S I=$O(^VA(15.1,I)) Q:I'>0 S X=X+1,X(I)=""
97 I X=1 Q $O(X(""))
98 K DIC S DIC=15.1,DIC(0)="AEQM",DIC("A")="Which FILE are the potential duplicates in (e.g., PATIENT)? ",DIC("B")="PATIENT" D ^DIC K DIC
99 Q +Y
100 ;
101CMORS ; RETURN DATA RANKED BY CMORS (HIGH VALUES FIRST)
102 I '$D(^VA(15,"ACMORS")) D SETCMOR
103 I $G(^VA(15,"ACMORS",0))'>0 D SETCMOR
104 I $G(^VA(15,"ACMORS",0))>0,$$FMDIFF^XLFDT(DT,^(0))>7 D ASKCMOR
105 I ICNT1>0 S ICNT=ICNT-1
106 S LCNT=0
107 F ICNT=ICNT:0 S ICNT=$O(^VA(15,"ACMORS",ICNT)) Q:ICNT'>0 D Q:('(NCNT#4))&(LCNT>0)
108 . F ICNT1=+ICNT1:0 S ICNT1=$O(^VA(15,"ACMORS",ICNT,ICNT1)) Q:ICNT1'>0 D Q:('(NCNT#4))&(LCNT>0)
109 . . S X=$G(^VA(15,ICNT1,0)) Q:X="" Q:$P(X,U,3)'="P" S X1=+X,X2=+$P(X,U,2)
110 . . I $D(@TMPGLA@(X1,X2)) Q
111 . . S @TMPGLA@(X1,X2)=""
112 . . S NCNT=NCNT+1,LCNT=LCNT+1
113 . . S @TMPGLB@(NCNT)=ICNT1_U_X1_U_X2
114 . . S CMORS1=$P($G(^DPT(X1,"MPI")),U,6),CMORS2=$P($G(^DPT(X2,"MPI")),U,6)
115 . . S @TMPGLB@(NCNT,1)=@(U_XDRGLB_X1_",0)")_" (CMOR SCORE = "_$S(CMORS1="":"NULL",1:CMORS1)_")"
116 . . S @TMPGLB@(NCNT,2)=@(U_XDRGLB_X2_",0)")_" (CMOR SCORE = "_$S(CMORS2="":"NULL",1:CMORS2)_")"
117 Q
118 ;
119SETCMOR ;
120 N I,X,X1,X2,SCOR
121 K ^VA(15,"ACMORS")
122 F I=0:0 S I=$O(^VA(15,I)) Q:I'>0 S X=^(I,0) D
123 . I $P(X,U,3)'="P" Q
124 . I $P($P(X,U),";",2)'="DPT(" Q
125 . S X1=+X,X2=+$P(X,U,2)
126 . S SCOR=$P($G(^DPT(X1,"MPI")),U,6) I SCOR'>0 S SCOR=0
127 . S ^VA(15,"ACMORS",(9999999-SCOR),I)=""
128 . S SCOR=$P($G(^DPT(X2,"MPI")),U,6) I SCOR'>0 S SCOR=0
129 . S ^VA(15,"ACMORS",(9999999-SCOR),I)=""
130 S ^VA(15,"ACMORS",0)=DT
131 Q
132 ;
133ASKCMOR ;
134 N DIR
135 S DIR(0)="Y",DIR("A")="The CMOR scores for activity haven't been checked recently. Do you want to update these (It might take a couple of minutes)"
136 S DIR("B")="YES"
137 D ^DIR I Y>0 D SETCMOR
138 Q
139 ;
140SET1 ; HANDLES SETTING OF X-REF ON CMOR SCORES FOR POTENTIAL DUPLICATES
141 I X'="P" Q
142 N XDRXVAL,XDRXVAL1
143 S XDRXVAL=^VA(15,D0,0)
144 I $P($P(XDRXVAL,U),";",2)'="DPT(" Q
145 S XDRXVAL1=$P($G(^DPT(+XDRXVAL,"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1
146 S ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)=""
147 S XDRXVAL1=$P($G(^DPT(+$P(XDRXVAL,U,2),"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1
148 S ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)=""
149 Q
150 ;
151KILL1 ; HANDLES KILLING OF X-REF ON CMOR SCORES FOR POTENTIAL DUPLICATES
152 I X'="P" Q
153 N XDRXVAL,XDRXVAL1
154 S XDRXVAL=^VA(15,D0,0)
155 I $P($P(XDRXVAL,U),";",2)'="DPT(" Q
156 S XDRXVAL1=+$P($G(^DPT(+XDRXVAL,"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1
157 K ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)
158 S XDRXVAL1=+$P($G(^DPT(+$P(XDRXVAL,U,2),"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1
159 K ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)
160 Q
161 ;
162OTHERS ; CHECKS AND MARKS OTHER PAIRS SO ONLY ONE CAN BE PROCESSED AT A TIME
163 Q ; NOT USED CURRENTLY
164 ;
165 ; P CLEAR ALL RELATED
166 ;
167 ; X MARK ALL RELATED
168 ;
169 ; V CLEAR TO
170 ;
171 ; O NOTHING
172 ;
173 ; R MARK ALL RELATED
174 ;
175 ; MERGED CLEAR TO REALIGN FROM
176 I X="O" Q
177 N OLDDA,OLDX S OLDDA=DA,OLDX=X N DA,X
178 N XDRENTR,IENVAL,XDRPAIR,DONE,XDR0,STATUS,DIREC
179 I $D(XDROTHER) Q
180 N XDROTHER S XDROTHER=1
181 I OLDX="P"!(OLDX="N") D Q
182 . F XDRENTR=$P(^VA(15,OLDDA,0),U),$P(^VA(15,OLDDA,0),U,2) F IENVAL=0:0 S IENVAL=$O(^VA(15,"B",XDRENTR,IENVAL)) Q:IENVAL'>0 I IENVAL'=OLDDA,$P(^VA(15,IENVAL,0),U,3)="O" D
183 . . ; Have to check on whether the other member of the pair in process as well.
184 . . S XDRPAIR=$P(^VA(15,IENVAL,0),U) IF XDRPAIR=XDRENTR S XDRPAIR=$P(^(0),U,2)
185 . . S DONE=0 F IENPAIR=0:0 S IENPAIR=$O(^VA(15,"B",XDRPAIR,IENPAIR)) Q:IENPAIR'>0 I IENPAIR'=IENVAL D Q:DONE
186 . . . S XDR0=^VA(15,IENPAIR,0)
187 . . . S STATUS=$P(XDR0,U,3)
188 . . . I STATUS="X"!(STATUS="R") S DONE=1 Q
189 . . . I STATUS="V" D Q:DONE
190 . . . . S DIREC=$P(XDR0,U,4)
191 . . . . I $P(XDR0,U,DIREC)=XDRPAIR S DONE=1 Q ; IT IS THE 'FROM' ENTRY
192 . . . . Q
193 . . . Q
194 . . D RESET(IENVAL)
195 . . Q
196 . Q
197 I OLDX="X"!(OLDX="R") D Q
198 . F XDRENTR=$P(^VA(15,OLDDA,0),U),$P(^VA(15,OLDDA,0),U,2) F IENVAL=0:0 S IENVAL=$O(^VA(15,"B",XDRENTR,IENVAL)) Q:IENVAL'>0 I IENVAL'=OLDDA,$P(^VA(15,IENVAL,0),U,3)="P" D
199 . . N XDRXX S XDRXX(15,IENVAL_",",.03)="O"
200 . . D FILE^DIE("","XDRXX")
201 . Q
202 I OLDX="V"&$D(XDRDADJX) D Q ; IF MERGED (XDRDADJX IS SET IN XDRDAJD AND IS RUN BY A CROSS-REFERENCE FOR MERGE STATUS SET TO 'MERGED')
203 . F XDRENTR=$P(^VA(15,OLDDA,0),U),$P(^VA(15,OLDDA,0),U,2) D
204 . . S DIREC=$P(^VA(15,OLDDA,0),U,4)
205 . . F IENVAL=0:0 S IENVAL=$O(^VA(15,"B",XDRENTR,IENVAL)) Q:IENVAL'>0 I IENVAL'=OLDDA,$P(^VA(15,IENVAL,0),U,3)="O" D
206 . . . ; Have to check on whether the other member of the pair in process as well.
207 . . . S XDRPAIR=$P(^VA(15,IENVAL,0),U) IF XDRPAIR=XDRENTR S XDRPAIR=$P(^(0),U,2)
208 . . . S DONE=0 F IENPAIR=0:0 S IENPAIR=$O(^VA(15,"B",XDRPAIR,IENPAIR)) Q:IENPAIR'>0 I IENPAIR'=IENVAL D Q:DONE
209 . . . . S XDR0=^VA(15,IENPAIR,0)
210 . . . . S STATUS=$P(XDR0,U,3)
211 . . . . I STATUS="X"!(STATUS="R") S DONE=1 Q
212 . . . . I STATUS="V" D Q:DONE
213 . . . . . S DIREC=$P(XDR0,U,4)
214 . . . . . I $P(XDR0,U,DIREC)=XDRPAIR S DONE=1 Q ; IT IS THE 'FROM' ENTRY
215 . . . . . Q
216 . . . . Q
217 . . . D RESET(IENVAL) ; RESET TO "P"
218 . . . Q
219 . . Q
220 . Q
221 Q
222 ;
223RESET(DA) ;
224 N XDRXX,IENS,X
225 I $P(^VA(15,DA,0),U,5)>1 Q
226 D NAME^XDRDEDT(DA)
227 S X=^VA(15,DA,0)
228 S IENS=DA_","
229 S XDRXX(15,IENS,.03)="P"
230 I $P(X,U,4)'="" S XDRXX(15,IENS,.04)="@"
231 I $P(X,U,5)'="" S XDRXX(15,IENS,.05)="@"
232 I $P(X,U,7)'="" S XDRXX(15,IENS,.07)="@"
233 I $P(X,U,8)'="" S XDRXX(15,IENS,.08)="@"
234 I $P(X,U,10)'="" S XDRXX(15,IENS,.1)="@"
235 I $P(X,U,13)'="" S XDRXX(15,IENS,.13)="@"
236 I $P(X,U,14)'="" S XDRXX(15,IENS,.14)="@"
237 D FILE^DIE("","XDRXX")
238 S:$D(DUZ) $P(^VA(15,DA,0),U,12)=DUZ
239 K ^VA(15,DA,2)
240 K ^VA(15,DA,3)
241 Q
Note: See TracBrowser for help on using the repository browser.