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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1XDRMERG0 ;SF-IRMFO.SEA/JLI - START OF NON-INTERACTIVE BATCH MERGE ;04/28/2005 12:11
2 ;;7.3;TOOLKIT;**23,36,43,49,83,95**;Apr 25, 1995
3 ;;
4 ; Covered Under DBIA's (#2710, #2796, #3765)
5 ;
6 Q
7QUE ; This is the entry point for queueing a merge process
8 ;
9 D EN^XDRVCHEK ; update verified and/or ready to merge statuses if necessary
10 ;
11 G QUE^XDRMERGB ; CODE MOVED TO KEEP DOWN SIZE OF ROUTINE
12 ;
13DQ ; This is the entry point for actually processing the merge task
14 ; Either as the initial entry or on restart.
15 ;
16 N XDRZZZ,XDRFILE,XDRPACK,XDRPACKN,XDRSFILE,XDRFDA1,XDRPACKN
17 N XDRROU,XDRCODE,XDRGLOB,XDRDVALF,DIQUIET,RGRSICN,XDRTIME
18 S XDRDVALF=1,XDRZZZ=$NA(^TMP("XDRFROM",$J)) K @XDRZZZ
19 S DIQUIET=1,RGRSICN=1
20 ;
21 I $$NEWERR^%ZTER() N $ETRAP,$ESTACK S $ETRAP="D ERR^XDRMERG0"
22 E S X="ERR^XDRMERG0",@^%ZOSF("TRAP")
23 S XDRGLOB=^DIC($P(^VA(15.2,XDRFDA,0),U,2),0,"GL"),XDRGLOB=";"_$E(XDRGLOB,2,$L(XDRGLOB)),XDRTIME=$P(^VA(15.1,$P(^VA(15.2,XDRFDA,0),U,2),1),U,3)
24 F I=0:0 S I=$O(^VA(15.2,XDRFDA,2,I)) Q:I'>0 S X=^(I,0) D
25 . S @XDRZZZ@(+X,$P(X,U,2),((+X)_XDRGLOB),$P(X,U,2)_XDRGLOB)=$P(X,U,3) ; REVISED WITH 4 SUBSCRIPTS TO SAVE MERGE IMAGE IN FM STRUCTURED FILE
26 . ;
27 . ; THE FOLLOWING LINES OF CODE ADDED TO TAKE CARE OF RESTARTS IN WHICH THE LABORATORY POINTERS ARE IN AN INTERMEDIATE STATE PRIOR TO COMPLETION - JLI 03-22-99
28 . ; DURING THE MERGE PROCESS THE ^LR( ENTRY IS SET TO SIMPLY THE LRIEN VALUE AND A -9 NODE ADDED,
29 . ; AT THE END OF LAB MERGE PROCESSING, THE FROM PATIENT ENTRY HAS ITS LR VALUE SET TO THE LRIEN FOR THE TO ENTRY
30 . ; WHICH IS PRESENT UNTIL THE PATIENT ENTRIES ARE MERGED. IF THE MERGE IS STOPPED PRIOR TO THE LABORATORY
31 . ; PROCESSING BEING MARKED COMPLETE, ON RE-ENTRY INTO THE LAB PROCESSING PAIRS WITH THE FROM ENTRY LAB DATA LEFT
32 . ; IN EITHER OF THE ABOVE STATES ARE EXCLUDED FROM THE MERGE.
33 . ; THE FOLLOWING CODE RESTORES THE CORRECT LRIEN POINTER AND LR(LRIEN,0) NODE FOR THE FROM VALUES
34 . ;
35 . I XDRGLOB=";DPT(",$D(^DPT(+X,"LR")) D
36 . . N TO,LR,FROMVAR S TO=$P(X,U,2),LR=^DPT(+X,"LR"),LR=$G(^LR(LR,0)) I $P(LR,U,2)=2,$P(LR,U,3)=+X Q
37 . . I ($P(LR,U,2)=""&($P(LR,U,3)=""))!($P(LR,U,2)=2&($P(LR,U,3)=TO)) D
38 . . . N DA F DA=0:0 S DA=$O(^XDRM("B",((+X)_XDRGLOB),DA)) Q:DA'>0 S LR=^XDRM(DA,1,1,0) I LR["LAB DATA" S LR=$P(LR,U,2) I LR>0 S ^DPT(+X,"LR")=LR,^LR(LR,0)=LR_U_"2"_U_(+X) K ^LR(LR,-9) Q
39 . ; END OF CODE ADDITION FOR LAB POINTER PROBLEM
40 ;
41 ; DO DATA CHECKING BEFORE STARTING MERGE
42 ;
43 I $P(^VA(15.2,XDRFDA,0),U,4)="S" S $P(^(0),U,3,4)=$$NOW^XLFDT()_U_"A"
44 S XDRPRE=1 D
45 . S XDRFDA1=$$ADDSPECL("DATA CHECKING")
46 . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
47 . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^"
48 . D ENPAIR^XDRDVAL1($P(^VA(15.2,XDRFDA,0),U,2),XDRZZZ,XDRFDA) ; CHECK FOR DATA VALIDITY PROBLEMS, REMOVE ANY PAIRS THAT HAVE PROBLEMS
49 . D CHKFROM^XDRMERG2(XDRZZZ,$P(^VA(15.2,XDRFDA,0),U,2))
50 . I '$D(@XDRZZZ) D
51 . . D SETCOMPL ; MARK DATA CHECKING COMPLETE
52 . . S XDRFDA1=$$ADDSPECL("NO PAIRS LEFT") D SETCOMPL
53 . . S XDRFDA1=$$ADDSPECL("**STOPPED**")
54 . . K XDRPRE ; AND MAKE IT CLOSE WHOLE PROCESS
55 . D SETCOMPL
56 . Q
57 ;
58 I '$D(@XDRZZZ) Q
59 S XDRFILE=$P(^VA(15.2,XDRFDA,0),U,2) Q:XDRFILE'>0
60 I $P(^VA(15.2,XDRFDA,0),U,4)="S" S $P(^(0),U,3,4)=$$NOW^XLFDT()_U_"A"
61 E S I=$P(^VA(15.2,XDRFDA,0),U,7),$P(^(0),U,4,7)="A"_U_$$NOW^XLFDT()_U_U_(I+1)
62 ;
63 ; PROCESS ANY SPECIAL HANDLING INDICATED FOR PACKAGES
64 ;
65 F XDRPACK=0:0 S XDRPACK=$O(^DIC(9.4,XDRPACK)) Q:XDRPACK'>0 D Q:'$D(@XDRZZZ)
66 . F XDRSFILE=0:0 S XDRSFILE=$O(^DIC(9.4,XDRPACK,20,XDRSFILE)) Q:XDRSFILE'>0 D Q:'$D(@XDRZZZ)
67 . . I $P(^DIC(9.4,XDRPACK,20,XDRSFILE,0),U)=XDRFILE D
68 . . . S X=^DIC(9.4,XDRPACK,20,XDRSFILE,0)
69 . . . S XDRPACKN=$P(^DIC(9.4,XDRPACK,0),U)
70 . . . S XDRROU=$P(X,U,2,3)
71 . . . S XDRCODE=$G(^DIC(9.4,XDRPACK,20,XDRSFILE,1))
72 . . . S XDRFDA1=$$ADDSPECL(XDRPACKN)
73 . . . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
74 . . . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^"_ZTSK_U_XDRROU
75 . . . D DQ1
76 . . . I '$D(@XDRZZZ) D
77 . . . . S XDRFDA1=$$ADDSPECL("NO PAIRS LEFT") D SETCOMPL
78 . . . . S XDRFDA1=$$ADDSPECL("**STOPPED**")
79 . . . . K XDRPRE ; AND MAKE IT CLOSE WHOLE PROCESS
80 K XDRPRE
81 ;
82 ; Mark completed and quit if no pairs are left
83 ;
84 I '$D(@XDRZZZ) S $P(^VA(15.2,XDRFDA,0),U,4)="C",$P(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT() Q
85 ;
86 ; NOW PROCESS THE MAIN FILE AND ITS DEPENDENCIES
87 ;
88 I '$D(ZTSTOP) D
89 . S XDRFDA1=$$ADDSPECL($P(^DIC(XDRFILE,0),U)_" FILE")
90 . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
91 . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK)
92 . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT()
93 . S X=^VA(15.2,XDRFDA,3,XDRFDA1,1)
94 . S XDRCSTAT=$P(X,U,2),XDRCFIL=$P(X,U,3),XDRCENT=$P(X,U,4)
95 . ;
96 . I XDRCSTAT'="" Q
97 . I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
98 ;
99 I '$D(ZTSTOP) D
100 . S XDRFDA2=XDRFDA1
101 . F S XDRFDA1=$O(^VA(15.2,XDRFDA,3,XDRFDA1)) Q:XDRFDA1'>0 D
102 . . S ZTRTN="RETHREAD^XDRMERG0",ZTIO="",ZTDESC="MERGE THREAD"
103 . . S ZTSAVE("XDRFDA")="",ZTSAVE("XDRFDA1")="",ZTDTH=$$NOW^XLFDT()
104 . . D ^%ZTLOAD
105 . I $P(^VA(15.2,XDRFDA,3,XDRFDA2,0),U,3)="C" Q
106 . S XDRFDA1=XDRFDA2 K XDRTHRED F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,XDRFDA1,2,I)) Q:I'>0 S J=^(I,0) S XDRTHRED(J)=""
107 . S ^VA(15.2,XDRFDA,1)=$$NOW^XLFDT()
108 . D RESTART^XDRMERG(XDRFILE,$NA(^TMP("XDRFROM",$J)),XDRCSTAT,XDRCFIL,XDRCENT)
109 ;
110 I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,0),U,4)="H"
111 E D SETCOMPL
112 Q
113 ;
114DQTHREAD ; START POINT FOR EXTRA THREADS
115 N XDRNAME,XDRFDA1,I,X,XDRZZZ,XDRTIME
116 S XDRZZZ=$NA(^TMP("XDRFROM",$J)) K @XDRZZZ
117 ;
118 S XDRFILE=$P($G(^VA(15.2,XDRFDA,0)),U,2) Q:XDRFILE'>0
119 S XDRTIME=$P(^VA(15.1,$P(^VA(15.2,XDRFDA,0),U,2),1),U,3)
120 S XDRNAME=" THREAD "_XDRTHRED
121 S XDRFDA1=$$ADDSPECL(XDRNAME)
122 I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
123 S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK)
124 S XDRGLOB=^DIC($P(^VA(15.2,XDRFDA,0),U,2),0,"GL"),XDRGLOB=";"_$E(XDRGLOB,2,$L(XDRGLOB))
125 F I=0:0 S I=$O(^VA(15.2,XDRFDA,2,I)) Q:I'>0 S X=^(I,0) D
126 . ; S @XDRZZZ@(+X,+$P(X,U,2))=$P(X,U,3) ; ORIGINAL VERSION WITH 2 SUBSCRIPTS
127 . S @XDRZZZ@(+X,$P(X,U,2),((+X)_XDRGLOB),$P(X,U,2)_XDRGLOB)=$P(X,U,3) ; REVISED WITH 4 SUBSCRIPTS TO SAVE MERGE IMAGE IN FM STRUCTURED FILE
128 F I=0:0 S I=$O(XDRTHRED(I)) Q:I'>0 D
129 . S ^VA(15.2,XDRFDA,3,XDRFDA1,2,I,0)=I
130 S X=$G(^VA(15.2,XDRFDA,3,XDRFDA1,1))
131 S XDRCFIL=+$P(X,U,3),XDRCENT=+$P(X,U,4)
132 D RESTART^XDRMERG(XDRFILE,$NA(^TMP("XDRFROM",$J)),3,XDRCFIL,XDRCENT)
133 I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
134 E D SETCOMPL
135 Q
136 ;
137RETHREAD ; RESTART THREADS
138 N I
139 K XDRTHRED
140 F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,XDRFDA1,2,I)) Q:I'>0 S J=^(I,0),XDRTHRED(J)=""
141 S XDRTHRED=$P($P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U)," THREAD ",2)
142 D DQTHREAD
143 Q
144 ;
145DQ1 ; HANDLE MERGE OF SPECIAL FILES
146 N X,XDRROU
147 S X=$G(^VA(15.2,XDRFDA,3,XDRFDA1,0))
148 I $P(X,U,3)="C" Q
149 S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK)
150 S $P(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT()
151 S X=^VA(15.2,XDRFDA,3,XDRFDA1,1)
152 S XDRCSTAT=$P(X,U,2),XDRCFIL=$P(X,U,3),XDRCENT=$P(X,U,4)
153 S XDRROU=$P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,8,9) Q:XDRROU=""
154 I $P(XDRROU,U)="" S XDRROU="EN"_XDRROU
155 D @(XDRROU_"(XDRZZZ)")
156 I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
157 E D SETCOMPL
158 Q
159 ;
160SETCOMPL ; Indicate that a component of the process was completed
161 ;
162 S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,5)=$$NOW^XLFDT()
163 S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C"
164 K ^VA(15.2,XDRFDA,3,XDRFDA1,1)
165 S J=1 F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,I)) Q:I'>0 I $P(^(I,0),U,3)'="C" S J=0 Q
166 I J=1,+$G(XDRPRE)=0 D ; All threads have completed
167 . S $P(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT()
168 . S $P(^VA(15.2,XDRFDA,0),U,4)="C"
169 . F XDRXX=0:0 S XDRXX=$O(@XDRZZZ@(XDRXX)) Q:XDRXX'>0 D
170 . . S XDRYY=$O(@XDRZZZ@(XDRXX,0)),XDRY1=$O(@XDRZZZ@(XDRXX,XDRYY,"")),XDRY2=$O(@XDRZZZ@(XDRXX,XDRYY,XDRY1,""))
171 . . S XDRK=@XDRZZZ@(XDRXX,XDRYY,XDRY1,XDRY2)
172 . . N XDRAA S XDRAA(15,(XDRK_","),.05)=2
173 . . D UPDATE^DIE("","XDRAA")
174 . . ;
175 . . ; recalc CMOR scores on newly merged TO record
176 . . I XDRY2[";DPT(",$T(CALC^RGVCCMR2)]"" D
177 . . . N RGDFN S RGDFN=XDRYY D CALC^RGVCCMR2
178 . . . ; create an A31 message for newly merged TO record
179 . . . S ERR=$$A31^MPIFA31B(XDRYY)
180 . . . I +ERR<0 D START^RGHLLOG(),EXC^RGHLLOG(208,"Error returned while building A31 after merge (DFN="_XDRYY_") ERROR="_$P(ERR,"^",2),XDRYY),STOP^RGHLLOG()
181 . S (FILE,XDRFILE)=$P(^VA(15.2,XDRFDA,0),U,2)
182 . S FROM=$NA(^TMP("XDRFROM",$J))
183 . D CLOSEIT^XDRMERG
184 . D SNDMSG^XDRMERGB(XDRFDA)
185 Q
186 ;
187ADDSPECL(PACKAGE) ; Add a package identifier to merge process
188 ; if already present, simply return the internal entry number
189 ; (it would be present if re-starting)
190 ;
191 N Y,XDRZZ,XDRXX
192 S Y=$$FIND1^DIC(15.23,","_XDRFDA_",","Q",PACKAGE)
193 I Y'>0 D
194 . S XDRZZ(15.23,"+1,"_XDRFDA_",",.01)=PACKAGE
195 . D UPDATE^DIE("","XDRZZ","XDRXX")
196 . S Y=XDRXX(1)
197 Q +Y
198 ;
199 ;
200ERR ; On an error mark status as error, and save the error message
201 ;
202 S XDRZE=$ZE
203 D ^%ZTER
204 I $D(XDRFDA),$D(XDRFDA1) D
205 . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="E",^(2)=XDRZE
206 G UNWIND^%ZTER
207 ;
Note: See TracBrowser for help on using the repository browser.