XDRMRG ;IHS/OHPRD/JCM - MERGE DUPLICATE RECORDS ;02/10/95 11:15
;;7.3;TOOLKIT;;Apr 25, 1995
START ;
D INIT
D:XDRM("PRE-MERGE")]"" @XDRM("PRE-MERGE")
G:XDRMRG("QFLG") END
D @$S('$D(XDRM("DINUMS")):"SINGLE",1:"MULTI")
G:XDRMRG("QFLG") END
I XDRM("POST-MERGE")]"" W:'$D(XDRM("NOTALK")) !!,"I will now do any post merge action that needs to occur, this may take some time please be patient." D @XDRM("POST-MERGE")
I XDRM("POST-MERGE")']"",$P(XDRM(0),U,26) D DELETE
D STATUS
END D EOJ
Q
;
INIT ;
F XDRI="XDRMRGFR","XDRMRGTO" K ^TMP(XDRI,$J)
S %X=XDRGL_XDRMRG("FR")_",",%Y="^TMP(""XDRMRGFR"",$J,"_XDRMRG("FR")_"," D %XY^%RCR
S %X=XDRGL_XDRMRG("TO")_",",%Y="^TMP(""XDRMRGTO"",$J,"_XDRMRG("TO")_"," D %XY^%RCR
K %X,%Y
S (XDRQFLG,XDRMRG("QFLG"))=0
I $D(XDRM("AUTO")),'$D(XDRM("NOTALK")) S (XDRM("NOTALK"),XDRM("NON-INTERACTIVE"))=""
I '$D(XDRM("DINUMS")),$O(^VA(15.1,XDRFL,12,0)) F XDRI=0:0 S XDRI=$O(^(XDRI)) Q:'XDRI S XDRM("DINUMS",XDRI)=""
K XDRI
Q
;
SINGLE ;
S XDRMRGFL=XDRFL,XDRMRGL=XDRGL
I '$D(XDRM("NON-INTERACTIVE")) K DITM D DITM2 G:XDRMRG("QFLG") SINGLEX I 1
E D DIT0
D PACKAGE
D DITMGMRG
SINGLEX Q
;
MULTI ;
S XDRMRGFL=XDRFL,XDRMRGL=XDRGL
I '$D(XDRM("NON-INTERACTIVE")) K DITM D DITM2 G:XDRMRG("QFLG") MULTIX I 1
E D DIT0
F XDRMRGFL=0:0 S XDRMRGFL=$O(XDRM("DINUMS",XDRMRGFL)) Q:'XDRMRGFL!(XDRMRG("QFLG")) S XDRMRGL=^DIC(XDRMRGFL,0,"GL") D @$S('$D(XDRM("NON-INTERACTIVE")):"DITM2",1:"DIT0")
G:XDRMRG("QFLG") MULTIX
S XDRMRGFL=XDRFL,XDRMRGL=XDRGL
D PACKAGE
F XDRI=0:0 S XDRI=$O(XDRM("DINUMS",XDRI)) Q:'XDRI S DITMGMRG("EXCLUDE",XDRI)=""
K XDRI
D DITMGMRG
F XDRMRGFL=0:0 S XDRMRGFL=$O(XDRM("DINUMS",XDRMRGFL)) Q:'XDRMRGFL S XDRMRGL=^DIC(XDRMRGFL,0,"GL") D DITMGMRG
MULTIX Q
;
DITM2 ;
S:XDRMRGFL'=XDRFL X="DITM2^XDRMRG1",@^%ZOSF("TRAP") K X
S:$D(XDRM("NOTALK")) DITM("NOTALK")=""
S:'$D(DITM("NOTALK")) DITM("DDSP")=""
S DITM("DIMERGE")=1
S DITM("DFF")=XDRMRGFL,DITM("DIC")=XDRMRGL
S DITM("DIT(1)")=XDRMRG("FR"),DITM("DIT(2)")=XDRMRG("TO"),DITM("DDEF")=2
S DITM("PACKAGE")="",DITM("EXCLUDE",15)="",IOP=IO(0)
W:'$D(XDRM("NOTALK")) !!,"I will now merge the ",$P(^DIC(XDRMRGFL,0),U,1)," file, this may take some time please be patient."
D ^DITM2 K DITM,IOP
D:$D(DIRUT)!($D(DMSG))!($D(DUOUT)) ASK
K DIRUT,DMSG
Q
;
ASK ;
W !!
S DIR(0)="YO",DIR("A")="Do you wish to continue MERGING these records",DIR("B")="N"
D ^DIR
I $D(DTOUT)!($D(DUOUT)) S XDRMRG("QFLG")=1 G ASKX
S:'Y XDRMRG("QFLG")=1
ASKX K DIR,DA,Y
Q
;
DIT0 ;
S:XDRMRGFL'=XDRFL X="DIT0^XDRMRG1",@^%ZOSF("TRAP") K X
W:'$D(XDRM("NOTALK")) !!,"I will now merge the ",$P(^DIC(XDRMRGFL,0),U,1)," file, this may take some time please be patient."
K DA
S (DIT("T"),DIT("F"))=XDRMRGL
S (D0,DA("T"))=XDRMRG("TO"),DA("F")=XDRMRG("FR")
D EN^DIT0 K D0,DA,DIC,DIK,DIT
Q
;
PACKAGE ;
F XDRMPKGE=0:0 S XDRMPKGE=$O(^VA(15,XDRMPDA,11,XDRMPKGE)) Q:'XDRMPKGE D:$P(^VA(15,XDRMPDA,11,XDRMPKGE,0),U,2)=1 MERGE
K XDRMPKGE
Q
;
MERGE ;
S X="MERGE^XDRMRG1",@^%ZOSF("TRAP") K X
W:'$D(XDRM("NOTALK")) !!,"I will now merge all files associated with the ",$P(^DIC(9.4,XDRMPKGE,0),U,1)," package."
W:'$D(XDRM("NOTALK")) !,"This may take some time, Please be patient."
I $D(^DIC(9.4,XDRMPKGE,20,XDRFL,0))#2,$P(^(0),U,3)]"" S XDRMRG("PKGMRG")=U_$P(^(0),U,3) D @XDRMRG("PKGMRG")
W:'$D(XDRM("NOTALK")) !!,"Completed merging all files associated with the ",$P(^DIC(9.4,XDRMPKGE,0),U,1)," package."
Q
DITMGMRG ;
S X="DITMGMRG^XDRMRG1",@^%ZOSF("TRAP") K X
W:'$D(XDRM("NOTALK")) !!,"I will now merge all files that point to the ",$P(^DIC(XDRMRGFL,0),U,1)," file that do not have a specific package merge ... This may take some time, please be patient."
S DITMGMRG("FILE")=XDRMRGFL,DITMGMRG("FR")=XDRMRG("FR"),DITMGMRG("TO")=XDRMRG("TO")
S DITMGMRG("EXCLUDE",15)="",DITMGMRG("PACKAGE")=""
S:$D(XDRM("NOTALK")) DITMGMRG("NOTALK")=""
S:$G(XDRM("TOP FILE")) DITMGMRG("TOP FILE")=XDRM("TOP FILE")
D EN^DITMGMRG K DITMGMRG
Q
;
DELETE ;
W:'$D(XDRM("NOTALK")) !!,"I will now delete the From Record from the ",$P(^DIC(XDRFL,0),U,1)," file and any files that were excluded from the repointing. This may take some time, please be patient."
K XDRMRGFL,XDRMRGL
I $D(XDRM("DINUMS")) F XDRMRGFL=0:0 S XDRMRGFL=$O(XDRM("DINUMS",XDRMRGFL)) Q:'XDRMRGFL S XDRMRGL=^DIC(XDRMRGFL,0,"GL") S DIK=XDRMRGL,DA=XDRMRG("FR") D DIK
S DIK=XDRGL,DA=XDRMRG("FR") D DIK
Q
;
DIK ;
S X="DIK^XDRMRG1",@^%ZOSF("TRAP") K X
D ^DIK K DIK,DA
Q
STATUS ;
S DIE="^VA(15,",DA=XDRMPDA,DR=".05////2;.08////"_DT D ^DIE K DIE,DR,DA
Q
EOJ ;
F XDRI="XDRMRGFR","XDRMRGTO" K ^TMP(XDRI,$J)
K DITM,DITMGMRG,XDRMRGFL,XDRMGL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRMRG 4708 printed Dec 13, 2024@02:39:35 Page 2
XDRMRG ;IHS/OHPRD/JCM - MERGE DUPLICATE RECORDS ;02/10/95 11:15
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
START ;
+1 DO INIT
+2 if XDRM("PRE-MERGE")]""
DO @XDRM("PRE-MERGE")
+3 if XDRMRG("QFLG")
GOTO END
+4 DO @$SELECT('$DATA(XDRM("DINUMS")):"SINGLE",1:"MULTI")
+5 if XDRMRG("QFLG")
GOTO END
+6 IF XDRM("POST-MERGE")]""
if '$DATA(XDRM("NOTALK"))
WRITE !!,"I will now do any post merge action that needs to occur, this may take some time please be patient."
DO @XDRM("POST-MERGE")
+7 IF XDRM("POST-MERGE")']""
IF $PIECE(XDRM(0),U,26)
DO DELETE
+8 DO STATUS
END DO EOJ
+1 QUIT
+2 ;
INIT ;
+1 FOR XDRI="XDRMRGFR","XDRMRGTO"
KILL ^TMP(XDRI,$JOB)
+2 SET %X=XDRGL_XDRMRG("FR")_","
SET %Y="^TMP(""XDRMRGFR"",$J,"_XDRMRG("FR")_","
DO %XY^%RCR
+3 SET %X=XDRGL_XDRMRG("TO")_","
SET %Y="^TMP(""XDRMRGTO"",$J,"_XDRMRG("TO")_","
DO %XY^%RCR
+4 KILL %X,%Y
+5 SET (XDRQFLG,XDRMRG("QFLG"))=0
+6 IF $DATA(XDRM("AUTO"))
IF '$DATA(XDRM("NOTALK"))
SET (XDRM("NOTALK"),XDRM("NON-INTERACTIVE"))=""
+7 IF '$DATA(XDRM("DINUMS"))
IF $ORDER(^VA(15.1,XDRFL,12,0))
FOR XDRI=0:0
SET XDRI=$ORDER(^(XDRI))
if 'XDRI
QUIT
SET XDRM("DINUMS",XDRI)=""
+8 KILL XDRI
+9 QUIT
+10 ;
SINGLE ;
+1 SET XDRMRGFL=XDRFL
SET XDRMRGL=XDRGL
+2 IF '$DATA(XDRM("NON-INTERACTIVE"))
KILL DITM
DO DITM2
if XDRMRG("QFLG")
GOTO SINGLEX
IF 1
+3 IF '$TEST
DO DIT0
+4 DO PACKAGE
+5 DO DITMGMRG
SINGLEX QUIT
+1 ;
MULTI ;
+1 SET XDRMRGFL=XDRFL
SET XDRMRGL=XDRGL
+2 IF '$DATA(XDRM("NON-INTERACTIVE"))
KILL DITM
DO DITM2
if XDRMRG("QFLG")
GOTO MULTIX
IF 1
+3 IF '$TEST
DO DIT0
+4 FOR XDRMRGFL=0:0
SET XDRMRGFL=$ORDER(XDRM("DINUMS",XDRMRGFL))
if 'XDRMRGFL!(XDRMRG("QFLG"))
QUIT
SET XDRMRGL=^DIC(XDRMRGFL,0,"GL")
DO @$SELECT('$DATA(XDRM("NON-INTERACTIVE")):"DITM2",1:"DIT0")
+5 if XDRMRG("QFLG")
GOTO MULTIX
+6 SET XDRMRGFL=XDRFL
SET XDRMRGL=XDRGL
+7 DO PACKAGE
+8 FOR XDRI=0:0
SET XDRI=$ORDER(XDRM("DINUMS",XDRI))
if 'XDRI
QUIT
SET DITMGMRG("EXCLUDE",XDRI)=""
+9 KILL XDRI
+10 DO DITMGMRG
+11 FOR XDRMRGFL=0:0
SET XDRMRGFL=$ORDER(XDRM("DINUMS",XDRMRGFL))
if 'XDRMRGFL
QUIT
SET XDRMRGL=^DIC(XDRMRGFL,0,"GL")
DO DITMGMRG
MULTIX QUIT
+1 ;
DITM2 ;
+1 if XDRMRGFL'=XDRFL
SET X="DITM2^XDRMRG1"
SET @^%ZOSF("TRAP")
KILL X
+2 if $DATA(XDRM("NOTALK"))
SET DITM("NOTALK")=""
+3 if '$DATA(DITM("NOTALK"))
SET DITM("DDSP")=""
+4 SET DITM("DIMERGE")=1
+5 SET DITM("DFF")=XDRMRGFL
SET DITM("DIC")=XDRMRGL
+6 SET DITM("DIT(1)")=XDRMRG("FR")
SET DITM("DIT(2)")=XDRMRG("TO")
SET DITM("DDEF")=2
+7 SET DITM("PACKAGE")=""
SET DITM("EXCLUDE",15)=""
SET IOP=IO(0)
+8 if '$DATA(XDRM("NOTALK"))
WRITE !!,"I will now merge the ",$PIECE(^DIC(XDRMRGFL,0),U,1)," file, this may take some time please be patient."
+9 DO ^DITM2
KILL DITM,IOP
+10 if $DATA(DIRUT)!($DATA(DMSG))!($DATA(DUOUT))
DO ASK
+11 KILL DIRUT,DMSG
+12 QUIT
+13 ;
ASK ;
+1 WRITE !!
+2 SET DIR(0)="YO"
SET DIR("A")="Do you wish to continue MERGING these records"
SET DIR("B")="N"
+3 DO ^DIR
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
SET XDRMRG("QFLG")=1
GOTO ASKX
+5 if 'Y
SET XDRMRG("QFLG")=1
ASKX KILL DIR,DA,Y
+1 QUIT
+2 ;
DIT0 ;
+1 if XDRMRGFL'=XDRFL
SET X="DIT0^XDRMRG1"
SET @^%ZOSF("TRAP")
KILL X
+2 if '$DATA(XDRM("NOTALK"))
WRITE !!,"I will now merge the ",$PIECE(^DIC(XDRMRGFL,0),U,1)," file, this may take some time please be patient."
+3 KILL DA
+4 SET (DIT("T"),DIT("F"))=XDRMRGL
+5 SET (D0,DA("T"))=XDRMRG("TO")
SET DA("F")=XDRMRG("FR")
+6 DO EN^DIT0
KILL D0,DA,DIC,DIK,DIT
+7 QUIT
+8 ;
PACKAGE ;
+1 FOR XDRMPKGE=0:0
SET XDRMPKGE=$ORDER(^VA(15,XDRMPDA,11,XDRMPKGE))
if 'XDRMPKGE
QUIT
if $PIECE(^VA(15,XDRMPDA,11,XDRMPKGE,0),U,2)=1
DO MERGE
+2 KILL XDRMPKGE
+3 QUIT
+4 ;
MERGE ;
+1 SET X="MERGE^XDRMRG1"
SET @^%ZOSF("TRAP")
KILL X
+2 if '$DATA(XDRM("NOTALK"))
WRITE !!,"I will now merge all files associated with the ",$PIECE(^DIC(9.4,XDRMPKGE,0),U,1)," package."
+3 if '$DATA(XDRM("NOTALK"))
WRITE !,"This may take some time, Please be patient."
+4 IF $DATA(^DIC(9.4,XDRMPKGE,20,XDRFL,0))#2
IF $PIECE(^(0),U,3)]""
SET XDRMRG("PKGMRG")=U_$PIECE(^(0),U,3)
DO @XDRMRG("PKGMRG")
+5 if '$DATA(XDRM("NOTALK"))
WRITE !!,"Completed merging all files associated with the ",$PIECE(^DIC(9.4,XDRMPKGE,0),U,1)," package."
+6 QUIT
DITMGMRG ;
+1 SET X="DITMGMRG^XDRMRG1"
SET @^%ZOSF("TRAP")
KILL X
+2 if '$DATA(XDRM("NOTALK"))
WRITE !!,"I will now merge all files that point to the ",$PIECE(^DIC(XDRMRGFL,0),U,1)," file that do not have a specific package merge ... This may take some time, please be patient."
+3 SET DITMGMRG("FILE")=XDRMRGFL
SET DITMGMRG("FR")=XDRMRG("FR")
SET DITMGMRG("TO")=XDRMRG("TO")
+4 SET DITMGMRG("EXCLUDE",15)=""
SET DITMGMRG("PACKAGE")=""
+5 if $DATA(XDRM("NOTALK"))
SET DITMGMRG("NOTALK")=""
+6 if $GET(XDRM("TOP FILE"))
SET DITMGMRG("TOP FILE")=XDRM("TOP FILE")
+7 DO EN^DITMGMRG
KILL DITMGMRG
+8 QUIT
+9 ;
DELETE ;
+1 if '$DATA(XDRM("NOTALK"))
WRITE !!,"I will now delete the From Record from the ",$PIECE(^DIC(XDRFL,0),U,1)," file and any files that were excluded from the repointing. This may take some time, please be patient."
+2 KILL XDRMRGFL,XDRMRGL
+3 IF $DATA(XDRM("DINUMS"))
FOR XDRMRGFL=0:0
SET XDRMRGFL=$ORDER(XDRM("DINUMS",XDRMRGFL))
if 'XDRMRGFL
QUIT
SET XDRMRGL=^DIC(XDRMRGFL,0,"GL")
SET DIK=XDRMRGL
SET DA=XDRMRG("FR")
DO DIK
+4 SET DIK=XDRGL
SET DA=XDRMRG("FR")
DO DIK
+5 QUIT
+6 ;
DIK ;
+1 SET X="DIK^XDRMRG1"
SET @^%ZOSF("TRAP")
KILL X
+2 DO ^DIK
KILL DIK,DA
+3 QUIT
STATUS ;
+1 SET DIE="^VA(15,"
SET DA=XDRMPDA
SET DR=".05////2;.08////"_DT
DO ^DIE
KILL DIE,DR,DA
+2 QUIT
EOJ ;
+1 FOR XDRI="XDRMRGFR","XDRMRGTO"
KILL ^TMP(XDRI,$JOB)
+2 KILL DITM,DITMGMRG,XDRMRGFL,XDRMGL
+3 QUIT
