source: WorldVistAEHR/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRMERGA.m@ 1710

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

initial load of WorldVistAEHR

File size: 8.2 KB
RevLine 
[613]1XDRMERGA ;SF-IRMFO.SEA/JLI - START OF NON-INTERACTIVE BATCH MERGE ;01/31/2000 09:14
2 ;;7.3;TOOLKIT;**23,28,37,40,45**;Apr 25, 1995
3 ;;
4 Q
5APPROVE ; This is the entry point for approving a duplicate pair for merge
6 K DIRUT,DUOUT,DTOUT ;
7 D EN^XDRVCHEK ; update verified and/or ready to merge statuses if necessary
8 ;
9 N XDRXX,XDRYY,XDRMA,DIE,DIC,DIR,DR,ZTDTH,ZTSK
10 N XDRX,XDRY,XDRFIL,XDRGLOB,X,Y,XDRNAME
11 N XDRFDA,XDRIENS,XDRI,XDRJ,XDRK,DA,DIK
12 ;
13 S XDRFIL=$$FILE^XDRDPICK() Q:XDRFIL'>0
14 S XDRDIC=^DIC(XDRFIL,0,"GL")
15 S XDRGLOB=$E(XDRDIC,2,999)
16 S X=""
17 S XNCNT=0,XNCNT0=0
18 F S X=$O(^VA(15,"AVDUP",XDRGLOB,X)) Q:X="" S Y=$O(^(X,0)) D
19 . N YVAL S YVAL=^VA(15,Y,0)
20 . I $P(YVAL,U,20)>0 Q ; ALREADY DONE OR SCHEDULED
21 . I $P(YVAL,U,3)'="V" Q ; TAKE ONLY VERIFIED
22 . I $P(YVAL,U,5)'=1 Q ; TAKE ONLY IF MARKED READY TO MERGE
23 . I $P(YVAL,U,4)="" D Q ; MAKE SURE MERGE DIRECTION IS DEFINED
24 . . W !,"Entry `",Y," DOES NOT HAVE MERGE DIRECTION DEFINED - CAN'T APPROVE"
25 . . N XDRDICA S XDRDICA=U_$P($P(YVAL,U),";",2)
26 . . I '$D(@(XDRDICA_(+YVAL)_",0)"))!$D(@(XDRDICA_(+YVAL)_",-9)"))!'$D(@(XDRDICA_(+$P(YVAL,U,2))_",0)"))!$D(@(XDRDICA_(+$P(YVAL,U,2))_",-9)")) D Q
27 . . . D RESET^XDRDPICK(Y)
28 . I $P(YVAL,U,13)'>0 D
29 . . I $P(YVAL,U,4)'=2 S XDRY(+YVAL,+$P(YVAL,U,2))=Y
30 . . E S XDRY(+$P(YVAL,U,2),+YVAL)=Y
31 . . S XNCNT0=XNCNT0+1
32 I XNCNT0>0 W !!,XNCNT0," Entries are awaiting approval for merging Return to continue..." R X:DTIME
33 I $D(XDRY) D CHKBKUP I $D(DUOUT)!$D(DTOUT) Q
34 K XDRY
35 Q
36 ;
37STOP ;
38 N XDRI,DIE,DA,DR,DIR,XDRC
39 S XDRC=0 F XDRI=0:0 S XDRI=$O(^VA(15.2,XDRI)) Q:XDRI'>0 I $P(^(XDRI,0),U,4)="A" D
40 . S XDRC=XDRC+1
41 . S DIR(0)="Y",DIR("A")="Do you want to stop "_$P(^VA(15.2,XDRI,0),U)
42 . D ^DIR K DIR I Y'>0 Q
43 . S DIE="^VA(15.2,",DA=XDRI,DR=".09///1" D ^DIE
44 . K DIE,DR
45 I XDRC'>0 W !!,$C(7),"No active merge processes were found.",!!
46 Q
47 ;
48CHKBKUP ; Check if backups have been generated for outstanding pairs
49 N I,J,X,Y,X1,X2,XNCNT,I,J,K,L,M,N,XX
50 K DIR
51 ;S DIR("A")="Do you want to check pairs awaiting backups (Y/N)"
52 ;S DIR("?")="Indication that a backup of the data for the entries for a duplicate pair is required prior to merging the entries. You may review entries to see if any should be marked as completed."
53 ;S DIR(0)="Y" D ^DIR K DIR Q:Y'>0
54 S ASKNAME="ASK1" D CHECK
55 Q
56 ;
57CHECK ;
58 W @IOF
59 S XNCNT=0
60 F I=0:0 S I=$O(XDRY(I)) Q:I'>0 D Q:$D(DUOUT)!$D(DTOUT)
61 . F J=0:0 S J=$O(XDRY(I,J)) Q:J'>0 D Q:$D(DUOUT)!$D(DTOUT)
62 . . S X01=$G(@(XDRDIC_I_",0)")),X1=$P(X01,U),X1S=$P(X01,U,9),X1S=$E(X1S,1,3)_"-"_$E(X1S,4,5)_"-"_$E(X1S,6,15)
63 . . S X02=$G(@(XDRDIC_J_",0)")),X2=$P(X02,U),X2S=$P(X02,U,9),X2S=$E(X2S,1,3)_"-"_$E(X2S,4,5)_"-"_$E(X2S,6,15)
64 . . I X1=""!(X2="") K XDRY(I,J) Q
65 . . F Q:X1'["MERGING INTO" S X1=$P($P(X1,"(",2,10),")",1,$L(X1,")")-1)
66 . . S XNCNT=XNCNT+1,XX(XNCNT)=I_U_J
67 . . W !!,$J(XNCNT,3)," ",?8,X1,?42,X1S,?60,"[",I,"]"
68 . . W !,?8,X2,?42,X2S,?60,"[",J,"]"
69 . . I '(XNCNT#6) D @ASKNAME Q:$D(DUOUT)!$D(DTOUT) W @IOF
70 I '($D(DUOUT)!$D(DTOUT)) D @ASKNAME
71 Q
72 ;
73ASK1 ;
74 W ! S DIR(0)="LO^1:"_XNCNT,DIR("A")="Select entries to approve them for merging"
75 ;W !,"TEST"
76 D ^DIR K DIR K DIRUT Q:$D(DUOUT)!$D(DTOUT)
77 S K="" F S K=$O(Y(K)) Q:K="" S Y=Y(K) K Y(K) D
78 . F M=1:1 S N=$P(Y,",",M) Q:N="" D
79 . . S N1=+XX(N),N2=$P(XX(N),U,2)
80 . . S (DA,XDRX(N1,N2))=XDRY(N1,N2)
81 . . N I,J,K,M,N,N1,N2,X1,X2,X,DIE,DR,Y
82 . . S DIE="^VA(15,"
83 . . S X=DT,X=$$FMTE^XLFDT(X,"2D")
84 . . S X=$P($P(^VA(200,DUZ,0),U),",",2)_" "_$P($P(^(0),U),",")_" (DUZ="_DUZ_") "_X
85 . . S DR=".13///1;.14///"_X
86 . . D ^DIE
87 Q
88 ;
89RESTART ; Entry point to restart non-completed merges
90 N NC,N S NC=0
91 F XDRFDA=0:0 S XDRFDA=$O(^VA(15.2,XDRFDA)) Q:XDRFDA'>0 D
92 . S X=$P(^VA(15.2,XDRFDA,0),U,4) I X="C"!(X="A") S N=1 D Q:N=1
93 . . F J=0:0 S J=$O(^VA(15.2,XDRFDA,3,J)) Q:J'>0 I "CA"'[$P(^(J,0),U,3) S N=0 Q
94 . S NC=NC+1
95 . S DIR(0)="Y",DIR("A")="Do you want to RESTART merge process "_$P(^VA(15.2,XDRFDA,0),U),DIR("B")="NO"
96 . D ^DIR K DIR Q:Y'>0
97 . S ZTRTN="DQ^XDRMERG0",ZTSAVE("XDRFDA")="",ZTIO="NULL"
98 . D ^%ZTLOAD I '$D(ZTSK) W !!,$C(7),"RESTART **NOT** QUEUED" Q
99 . S $P(^VA(15.2,XDRFDA,0),U,8,9)=ZTSK_U ; SET TASK NUMBER AND REMOVE HALT FLAG IF SET
100 . W !,"Restart queued as task ",ZTSK,!
101 I NC'>0 W !!,$C(7),"No merge processes found that needed restarting.",!!
102 Q
103 ;
104 ;
105DOSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ;
106 N NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR
107 N XDRAA,XDRZZ ; DEBUG STATEMENT
108 S SFILE=+$P($G(@(XDRFROM_"0)")),U,2)
109 I SFILE'>0 Q ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE
110 I $P($G(^DD(SFILE,.01,0)),U,2)["W" D Q ; HANDLE WORD PROCESSING FIELDS
111 . N XF,XT S XT=$E(XDRTO,1,$L(XDRTO)-1)_")"
112 . I '$D(@XT) D
113 . . S XF=$E(XDRFROM,1,$L(XDRFROM)-1)_")"
114 . . M @XT=@XF
115 . . Q
116 . Q
117 F NODEA=0:0 S NODEA=$O(@(XDRFROM_NODEA_")")) Q:NODEA'>0 D
118 . S VALUE=$P($G(@(XDRFROM_NODEA_",0)")),U) ; GET .01 VALUE
119 . N XDRDT S XDRDT=^DD(SFILE,.01,0)
120 . I $P(XDRDT,U,2)["D" S XDRDT=$P(XDRDT,U,5,999),XDRDINUM=$S(XDRDT["DINUM":1,1:0) I XDRDINUM S XDRDT=0 D DINUMDAT Q:XDRDT ; HANDLE DINUMED DATES BY SIMPLY MOVING THEM
121 . S YVALUE=0,XVALUE=0 I $D(^DD(SFILE,.001,0)) S YVALUE=NODEA I $D(@(XDRTO_NODEA_")")) S XVALUE=YVALUE
122 . I XVALUE=0,$P(^DD(SFILE,.01,0),U,5,99)["DINUM",$D(@(XDRTO_NODEA_")")) S XVALUE=NODEA
123 . I XVALUE=0 S XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE) ; FIND CURRENT ENTRY NUMBER, IF PRESENT
124 . I XVALUE>0 D Q ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES
125 . . N X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN
126 . . S NODE=""
127 . . F S NODE=$O(@(XDRFROM_NODEA_","""_NODE_""")")) Q:NODE="" D
128 . . . I $D(@(XDRFROM_NODEA_","""_NODE_""")"))'>1 Q
129 . . . S NEWFROM=XDRFROM_NODEA_","""_NODE_""","
130 . . . S NEWTO=XDRTO_XVALUE_","""_NODE_""","
131 . . . S NEWTOIEN=XVALUE_","_IENTOSTR
132 . . . D DOSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ))
133 . K XDRYY I YVALUE>0 S XDRYY(1)=YVALUE
134 . S XENTOSTR="+1,"_IENTOSTR
135 . S XDRFILTY=$P($G(^DD(SFILE,.01,0)),U,2)
136 . I XDRFILTY["P" S VALUE="`"_VALUE
137 . I XDRFILTY["V" D
138 . . N Y S Y=$P(VALUE,";",2) Q:Y=""
139 . . S Y=$P($G(@("^"_Y_"0)")),U) Q:Y=""
140 . . S VALUE=Y_".`"_(+VALUE)
141 . . Q
142 . I SFILE=70.03 S XDRFILTY="D" ;use internal data for file 70.03
143 . I XDRFILTY'["P"&(XDRFILTY'["V"),XDRFILTY'["D" S VALUE=$$GETEXT(XDRFROM,NODEA,SFILE)
144 . S XDRXX(SFILE,XENTOSTR,.01)=VALUE
145 . I $O(^DD(SFILE,0,"ID",0))>0 D
146 . . ;CODE FOR ADDING IDENTIFIERS
147 . . N I,N,XDRFROM1,IENFR
148 . . S N=0,I=SFILE F S I=$G(^DD(I,0,"UP")) Q:I'>0 S N=N+1
149 . . S XDRFROM1=$P(XDRFROM,"(",2,99),IENFR=NODEA_","
150 . . F I=$L(XDRFROM1,",")-2:-2 Q:N'>0 S IENFR=IENFR_$P(XDRFROM1,",",I)_",",N=N-1
151 . . ;
152 . . F XDRID=0:0 S XDRID=$O(^DD(SFILE,0,"ID",XDRID)) Q:XDRID'>0 D
153 . . . S N=$$GET1^DIQ(SFILE,IENFR,XDRID)
154 . . . I N'="" S XDRXX(SFILE,XENTOSTR,XDRID)=N
155 . . . Q
156 . . Q
157 . ;
158 . K XDRAA,XDRZZ I $D(XDRTESTK) M XDRAA=XDRXX ; DEBUG STATEMENT
159 . ; DATES THAT ARE DINUMED HAVE BEEN HANDLED ABOVE, SO CAN PASS A DATE IN AS AN INTERNAL VALUE
160 . D UPDATE^DIE($S(XDRFILTY["D":"",1:"E"),"XDRXX","XDRYY","XDRZZ") ; CREATE A NEW ENTRY IN IENTO FOR VALUE
161 . I $D(XDRZZ),$D(XDRTESTK),SFILE'=2.0361 S XDRTESTK=XDRTESTK+1 M ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ ; DEBUG STATEMENT
162 . S NODEB=$G(XDRYY(1)) I NODEB'>0 Q
163 . M @(XDRTO_NODEB_")")=@(XDRFROM_NODEA_")")
164 . S DIK=XDRTO,DA=NODEB D
165 . . F I=1:1 S DA(I)=$P(XDRDASEQ,U,I) I DA(I)="" K DA(I) Q
166 . I SFILE=55.06 N DIU S DIU(0)=1 F DIK(1)=".01^B","10^AUDS","34^AUD","64^AUDDD","7^ACR1" D EN1^DIK
167 . I SFILE'=55.06 N DIU S DIU(0)=1 D IX^DIK
168 Q
169 ;
170GETEXT(DICA,DA,FILNUM) ; GET EXTERNAL VALUE FOR .01 FIELD
171 N DIC,DIQ,DR,XDRQ
172 S DIC=DICA,DIC("P")=FILNUM,DR=.01,DIQ="XDRQ",DIQ(0)="E"
173 D EN^DIQ1
174 Q $G(XDRQ(FILNUM,DA,.01,"E"))
175 ;
176DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM
177 N NEWVAL,NODETO
178 S NODETO=NODEA
179 I $D(@(XDRTO_NODEA_")")) Q:(SFILE'=63.04) D
180 . S NEWVAL=VALUE
181 . F Q:'$D(@(XDRTO_NODETO_")")) S NODETO=NODETO-.000001,NEWVAL=NEWVAL+.000001
182 M @(XDRTO_NODETO_")")=@(XDRFROM_NODEA_")")
183 I $D(NEWVAL) S $P(@(XDRTO_NODETO_",0)"),U)=NEWVAL
184 S DIK=XDRTO,DA=NODEA D D IX^DIK
185 . F I=1:1 S DA(I)=$P(XDRDASEQ,U,I) I DA(I)="" K DA(I) Q
186 S XDRDT=1
187 Q
188 ;
189DODIS ; CODE TO HANDLE DISPOSITION ENTRIES IN PATIENT FILE
190 N XDRI,DA,DIK
191 F XDRI=0:0 S XDRI=$O(@(XDRDIC_IENFROM_",""DIS"","_XDRI_")")) Q:XDRI'>0 D
192 . I $D(@(XDRDIC_IENTO_",""DIS"","_XDRI_")")) Q
193 . M @(XDRDIC_IENTO_",""DIS"","_XDRI_")")=@(XDRDIC_IENFROM_",""DIS"","_XDRI_")")
194 . S DA=XDRI,DA(1)=IENTO,DIK=XDRDIC_IENTO_",""DIS""," D IX^DIK
195 . Q
196 Q
197 ;
Note: See TracBrowser for help on using the repository browser.