- 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 Feb 19, 2025@00:06:03 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