EASXDR1 ;ALB/BRM/PHH - CHECK RELATIONS DURING XDR PATIENT MERGE; ; 5/30/03 12:29pm
;;1.0;ENROLLMENT APPLICATION SYSTEM;**10,26**;Mar 15, 2001
;
CHKRELAT(DFNFR,DFNTO,SILENT) ;can the relations on these 2 records be merged?
;
;INPUT:
; DFNFR : the patient file ien of the merge from record
; DFNTO : the patient file ien of the merge to record
; SILENT: (optional) used to prevent screen writes and user
; interaction during the merge process
;
; Note: DFNFR and DFNTO can both be the same if this process is
; to clean-up patient relation file entries within the same
; patient
;
Q:'$G(DFNFR) "0^From DFN not passed"
Q:'$G(DFNTO) "0^To DFN not passed"
Q:'$D(^DGPR(408.12,"B",DFNFR)) "0^This patient did not have any relation entries that needed to be merged."
Q:'$D(^DGPR(408.12,"B",DFNTO)) "0^This patient did not have any relation entries that needed to be merged."
N ARYNAM2,REL,RELAT,NOMRGMSG,REASON,ARYNAM,X,ERR,NAMFIL
N ERROR,DIC,FRDATA,MRGFRIEN,MRGTOIEN,MSG,NAME,RELPNTR
N ACTOK,RELATE,EFFDT,SUBIEN,UPDMSG,MRGARY,MRGROOT,OK,IEN12TO
N ACTIVFR,ACTIVTO,SUBIENFR,SUBIENTO,ERRNUM,NAMIEN,IEN12FR
S MRGROOT="^TMP($J,""EASXDR1"",""B"")"
K ^TMP($J,"EASXDR1"),^TMP($J,"EASXDR")
S ^XTMP("EASXDR1",0)=$$FMADD^XLFDT($$NOW^XLFDT(),45)_U_$$NOW^XLFDT()_U_"EASXDR1 - DUPLICATE PATIENT RELATION MERGE"
; find 408.12 entries for FROM and TO records
F X="IEN12FR","IEN12TO" D
.S REL="DFN"_$E(X,6,7),@X=""
.S ARYNAM="^TMP($J,""EASXDR1"","""_$E(X,6,7)_""")"
.S ARYNAM2="^TMP($J,""EASXDR1"",""B"","""_$E(X,6,7)_""")"
.F S @X=$O(^DGPR(408.12,"B",@REL,@X)) Q:'@X D
..I '$D(^DGPR(408.12,@X)) S @ARYNAM@(@X)=(@REL)_"^NO 408.12 RECORD" Q
..M @ARYNAM@((@X))=^DGPR(408.12,@X)
..S RELPNTR=$P($G(@ARYNAM@(@X,0)),"^",3)
..S NAMIEN=$P(RELPNTR,";")_",",NAMFIL=$P(RELPNTR,";",2)
..I NAMFIL="DPT(" S NAMFIL=2
..E S NAMFIL=$TR($P(NAMFIL,"(",2),",")
..K NAME
..I NAMIEN,NAMFIL S NAME=$$GET1^DIQ(NAMFIL,NAMIEN,.01)
..S @ARYNAM@(@X,"NAME")=$G(NAME)
..S RELAT=$P($G(^DGPR(408.12,@X,0)),"^",2)
..S @ARYNAM2@(RELAT,@X)=""
; merge duplicate records (if they exist)
S RELATE="",OK=0,ERRNUM=0
F S RELATE=$O(@MRGROOT@("TO",RELATE)) Q:'RELATE D
.S MRGTOIEN=""
.F S MRGTOIEN=$O(@MRGROOT@("TO",RELATE,MRGTOIEN)) Q:'MRGTOIEN D LOOP
Q +$G(OK)
LOOP ;
M ^TMP($J,"EASXDR","MRGTO",MRGTOIEN)=^DGPR(408.12,MRGTOIEN)
S MRGFRIEN=""
F S MRGFRIEN=$O(@MRGROOT@("FR",RELATE,MRGFRIEN)) Q:'MRGFRIEN D
.Q:MRGFRIEN=MRGTOIEN ;do not update if FROM and TO iens are the same
.K ERROR
.I RELATE'=1 D Q:$D(ERROR)
..I '$$MRGOTHR(MRGFRIEN,MRGTOIEN) S ERROR(MRGFRIEN)="DEPENDENT NAMES DO NOT MATCH" K @MRGROOT@("FR",RELATE,MRGTOIEN) Q
..I '$$SSNMATCH(MRGFRIEN,MRGTOIEN) D Q:$D(ERROR)
...Q:$P($G(^DGPR(408.12,MRGFRIEN,0)),"^",2)'=$P($G(^DGPR(408.12,MRGTOIEN,0)),"^",2)
...S ERROR(MRGFRIEN)="DEPENDENT SSNS DO NOT MATCH"
...D:'$G(SILENT) FAILED(MRGFRIEN,MRGTOIEN,$G(ERROR(MRGFRIEN)))
...K @MRGROOT@("FR",RELATE,MRGTOIEN)
.M ^TMP($J,"EASXDR","MRGFR",MRGFRIEN)=^DGPR(408.12,MRGFRIEN)
.S EFFDT=""
.F S EFFDT=$O(^TMP($J,"EASXDR","MRGFR",MRGFRIEN,"E","B",EFFDT)) Q:'EFFDT D
..I $D(^DGPR(408.12,MRGTOIEN,"E","B",EFFDT)) D Q
...S ACTOK=$$CHKACT()
..S SUBIEN=+$O(^TMP($J,"EASXDR","MRGFR",MRGFRIEN,"E","B",EFFDT,""))
..Q:('SUBIEN)!('$D(^TMP($J,"EASXDR","MRGFR",MRGFRIEN,"E",SUBIEN)))
..S FRDATA=$G(^TMP($J,"EASXDR","MRGFR",MRGFRIEN,"E",SUBIEN,0))
..S UPDMSG=$$UPDATE(MRGTOIEN,FRDATA,MRGFRIEN)
..I 'UPDMSG D Q
...S ERROR(MRGFRIEN,SUBIEN)=$P(UPDMSG,"^",2),ERRNUM=ERRNUM+1
...Q:$P(UPDMSG,"^",2)="The entry does not exist."
...S ^XTMP("EASXDR1","DATA",DFNFR,"ERROR - NOT MERGED",MRGFRIEN,SUBIEN)=$P(UPDMSG,"^",2)
.I '$D(ERROR),$$REMOVE(MRGFRIEN,MRGTOIEN) D ;
..S OK=OK+1
..D:'$G(SILENT) SUCCESS(MRGFRIEN,MRGTOIEN)
..K @MRGROOT@("FR",RELATE,MRGFRIEN)
..K @MRGROOT@("TO",RELATE,MRGFRIEN)
..I $D(@MRGROOT@("TO",RELATE,MRGFRIEN)) K @MRGROOT@("TO",RELATE,MRGFRIEN)
..K ^TMP($J,"EASXDR")
..M ^TMP($J,"EASXDR","MRGFR",MRGFRIEN)=^DGPR(408.12,MRGFRIEN)
..M ^TMP($J,"EASXDR","MRGTO",MRGTOIEN)=^DGPR(408.12,MRGTOIEN)
Q
CHKACT() ; ensure both records contain the same active flag for eff. date
N OK
S OK=1
S SUBIENFR=+$O(^TMP($J,"EASXDR","MRGFR",MRGFRIEN,"E","B",EFFDT,""))
S SUBIENTO=+$O(^TMP($J,"EASXDR","MRGTO",MRGTOIEN,"E","B",EFFDT,""))
S ACTIVFR=$P($G(^TMP($J,"EASXDR","MRGFR",MRGFRIEN,"E",SUBIENFR,0)),"^",2)
S ACTIVTO=$P($G(^TMP($J,"EASXDR","MRGTO",MRGTOIEN,"E",SUBIENTO,0)),"^",2)
I ACTIVFR'=ACTIVTO D Q OK
.S OK=0
.S ERROR(MRGFRIEN,SUBIENFR)="'Active' flag does not match for effective date: "_$$FMTE^XLFDT(EFFDT),ERRNUM=ERRNUM+1
.S ^XTMP("EASXDR1","DATA",DFNFR,408.12,"ERROR - NOT MERGED",MRGFRIEN,SUBIENFR)=ERROR(MRGFRIEN,SUBIENFR)
.D:'$G(SILENT) FAILED(MRGFRIEN,MRGTOIEN,$G(ERROR(MRGFRIEN,SUBIENFR)))
.I '$D(ERROR) S OK=1
Q OK
UPDATE(MRGTOIEN,FRDATA,MRGFRIEN) ;
Q:('MRGTOIEN)!(FRDATA="") "0^RECORD NOT UPDATED - BAD INPUT DATA"
N DIERR,IENS,FDA,MSGROOT,IENROOT,NAMEFR,NAMETO
S IENS="+1,"_MRGTOIEN_","
S FDA(408.1275,IENS,.01)=$P(FRDATA,"^")
S FDA(408.1275,IENS,.02)=$P(FRDATA,"^",2)
S FDA(408.1275,IENS,.03)=$P(FRDATA,"^",3)
S FDA(408.1275,IENS,.04)=$P(FRDATA,"^",4)
S NAMEFR=$G(^TMP($J,"EASXDR1","FR",MRGFRIEN,"NAME"))
I NAMEFR="" S NAMEFR=$$GET1^DIQ(408.12,MRGFRIEN_",",.03,"E")
S NAMETO=$G(^TMP($J,"EASXDR1","TO",MRGTOIEN,"NAME"))
I NAMETO="" S NAMEFR=$$GET1^DIQ(408.12,MRGTOIEN_",",.03,"E")
D UPDATE^DIE("","FDA","IENROOT","MSGROOT")
I '$D(DIERR) D Q "1^UPDATED "_$G(IENROOT)
.K @MRGROOT@("FR",RELATE,MRGFRIEN)
.K @MRGROOT@("TO",RELATE,MRGFRIEN)
.I $D(@MRGROOT@("TO",RELATE,MRGFRIEN)) K @MRGROOT@("TO",RELATE,MRGFRIEN)
.K ^TMP($J,"EASXDR")
.M ^TMP($J,"EASXDR","MRGFR",MRGFRIEN)=^DGPR(408.12,MRGFRIEN)
.M ^TMP($J,"EASXDR","MRGTO",MRGTOIEN)=^DGPR(408.12,MRGTOIEN)
Q "0^"_$G(MSGROOT("DIERR",1,"TEXT",1))
DEL(ROOT,IEN) ;delete entries
Q:'IEN "1^INVALID INPUT PARAMETER"
N DA,DIK,MSG,X,Y,FILE
S FILE=$TR($P(ROOT,"(",2),",")
S MSG="1^DELETE ERROR "_ROOT_IEN ;default to error condition
M ^XTMP("EASXDR1","DATA",DFNFR,FILE,IEN)=@(ROOT_IEN_")")
S DA=IEN,DIK=ROOT D ^DIK,IX^DIK S MSG="0^RECORD DELETED"
Q MSG
MRGOTHR(MRGFRIEN,MRGTOIEN) ;
Q:('MRGFRIEN)!('MRGTOIEN) 0
N NAMEFR,NAMETO
S NAMEFR=$G(^TMP($J,"EASXDR1","FR",MRGFRIEN,"NAME"))
S NAMETO=$G(^TMP($J,"EASXDR1","TO",MRGTOIEN,"NAME"))
I NAMEFR=NAMETO Q 1 ;ok to proceed with dependent merge
Q 0 ;different dependent - do not merge entries.
SUCCESS(MRGFRIEN,MRGTOIEN) ;display message when merge is successful
Q:('$D(MRGFRIEN))!('$D(MRGTOIEN))
S NAMEFR=$G(^TMP($J,"EASXDR1","FR",MRGFRIEN,"NAME"))
I NAMEFR="" S NAMEFR=$$GET1^DIQ(408.12,MRGFRIEN_",",.03,"E")
S NAMETO=$G(^TMP($J,"EASXDR1","TO",MRGTOIEN,"NAME"))
I NAMETO="" S NAMEFR=$$GET1^DIQ(408.12,MRGTOIEN_",",.03,"E")
W !!?2,MRGFRIEN," ",NAMEFR," was merged into ",MRGTOIEN," ",NAMETO
Q
FAILED(MRGFRIEN,MRGTOIEN,MSG) ;display message when merge fails
Q:('$D(MRGFRIEN))!('$D(MRGTOIEN))!('$D(MSG))
N EFFDT1
S NAMEFR=$G(^TMP($J,"EASXDR1","FR",+MRGFRIEN,"NAME"))
I NAMEFR="" S NAMEFR=$$GET1^DIQ(408.12,MRGFRIEN_",",.03,"E")
S NAMETO=$G(^TMP($J,"EASXDR1","TO",+MRGTOIEN,"NAME"))
I NAMETO="" S NAMEFR=$$GET1^DIQ(408.12,MRGTOIEN_",",.03,"E")
W !!?2,MRGFRIEN," ",NAMEFR," could not be merged into ",MRGTOIEN," ",NAMETO,"."
W !?2,"Reason: ",$G(MSG)
S EFFDT1=$G(EFFDT)
I MSG["'Active' flag does not match" D
.D CHGACT^EASXDR(MRGFRIEN,MRGTOIEN,$G(EFFDT))
.S EFFDT=EFFDT1
.K ^TMP($J,"EASXDR1","FR",RELATE,MRGTOIEN)
Q
REMOVE(MRGFRIEN,MRGTOIEN) ;delete and/or repoint "old" entries
Q:('MRGFRIEN) "0^RECORD NOT DELETED - BAD INPUT DATA"
I '$D(MRGTOIEN) N MRGTOIEN S MRGTOIEN="***DELETE***"
I '$D(DFNFR) N DFNFR S DFNFR="DELETE" ;from DFN is not present
N VARPNT,MSG22,MSG21,ERROR,IEN40821,IEN40822,IEN40812,IEN40813
N MSG12,MSG13,VARPNT2
S IEN40812=MRGFRIEN
S IEN40821=""
S ^XTMP("EASXDR1","DATA",DFNFR,408.12,MRGFRIEN)=$S(MRGTOIEN:"RECORD MERGED INTO 408.12 IEN # "_MRGTOIEN,1:"RECORD DELETED")
F S IEN40821=$O(^DGMT(408.21,"C",IEN40812,IEN40821)) Q:'IEN40821!($G(ERROR)) D
.S IEN40822=""
.F S IEN40822=$O(^DGMT(408.22,"AIND",IEN40821,IEN40822)) Q:'IEN40822!($G(ERROR)) D
..S MSG22=$$DEL("^DGMT(408.22,",IEN40822)
..I MSG22 S ERROR="1^"_IEN40822_"^"_$P(MSG22,"^",2)_"^408.22 DELETE" Q
..I DFNFR="DELETE" S ^XTMP("EASXDR1","DATA",DFNFR,408.12,MRGFRIEN,"SEE 408.22",IEN40822)=""
.Q:$G(ERROR)
.S MSG21=$$DEL("^DGMT(408.21,",IEN40821)
.I MSG21 S ERROR="1^"_IEN40821_"^"_$P(MSG21,"^",2)_"^408.21 DELETE" Q
.I DFNFR="DELETE" S ^XTMP("EASXDR1","DATA",DFNFR,408.12,MRGFRIEN,"SEE 408.21",IEN40821)=""
Q:$G(ERROR) "0^"_$P(ERROR,"^",2,4)
S VARPNT=$P($G(^DGPR(408.12,IEN40812,0)),"^",3)
S IEN40813="" S:VARPNT["DGPR" IEN40813=$P(VARPNT,";")
S MSG12=$$DEL("^DGPR(408.12,",IEN40812)
I MSG12 Q "0^"_IEN40812_"^"_$P(MSG12,"^",2)_"^408.12 DELETE"
Q:'IEN40813 "1^"_MRGFRIEN_" DELETED"
S VARPNT2=""
;ensure that the new record is not pointing to the same relation
S:MRGTOIEN VARPNT2=$P($G(^DGPR(408.12,MRGTOIEN,0)),"^",3)
Q:VARPNT=VARPNT2 "1^"_MRGFRIEN_" DELETED"
S MSG13=$$DEL("^DGPR(408.13,",IEN40813)
I DFNFR="DELETE" S ^XTMP("EASXDR1","DATA",DFNFR,408.12,MRGFRIEN,"SEE 408.13",IEN40813)=""
Q:MSG13 "0^"_$P(MSG13,"^",2)
Q "1^"_MRGFRIEN_" DELETED"
SSNMATCH(FRIEN,TOIEN) ;
N SSNFR,SSNTO
D FINDSSN^EASXDR(FRIEN,.SSNFR),FINDSSN^EASXDR(TOIEN,.SSNTO)
Q:SSNFR=SSNTO 1 ;SSNs match
Q:(SSNFR="UNKNOWN")!(SSNFR="") 1 ;use SSN of the 'merge to' record
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASXDR1 9587 printed Dec 13, 2024@01:55:53 Page 2
EASXDR1 ;ALB/BRM/PHH - CHECK RELATIONS DURING XDR PATIENT MERGE; ; 5/30/03 12:29pm
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**10,26**;Mar 15, 2001
+2 ;
CHKRELAT(DFNFR,DFNTO,SILENT) ;can the relations on these 2 records be merged?
+1 ;
+2 ;INPUT:
+3 ; DFNFR : the patient file ien of the merge from record
+4 ; DFNTO : the patient file ien of the merge to record
+5 ; SILENT: (optional) used to prevent screen writes and user
+6 ; interaction during the merge process
+7 ;
+8 ; Note: DFNFR and DFNTO can both be the same if this process is
+9 ; to clean-up patient relation file entries within the same
+10 ; patient
+11 ;
+12 if '$GET(DFNFR)
QUIT "0^From DFN not passed"
+13 if '$GET(DFNTO)
QUIT "0^To DFN not passed"
+14 if '$DATA(^DGPR(408.12,"B",DFNFR))
QUIT "0^This patient did not have any relation entries that needed to be merged."
+15 if '$DATA(^DGPR(408.12,"B",DFNTO))
QUIT "0^This patient did not have any relation entries that needed to be merged."
+16 NEW ARYNAM2,REL,RELAT,NOMRGMSG,REASON,ARYNAM,X,ERR,NAMFIL
+17 NEW ERROR,DIC,FRDATA,MRGFRIEN,MRGTOIEN,MSG,NAME,RELPNTR
+18 NEW ACTOK,RELATE,EFFDT,SUBIEN,UPDMSG,MRGARY,MRGROOT,OK,IEN12TO
+19 NEW ACTIVFR,ACTIVTO,SUBIENFR,SUBIENTO,ERRNUM,NAMIEN,IEN12FR
+20 SET MRGROOT="^TMP($J,""EASXDR1"",""B"")"
+21 KILL ^TMP($JOB,"EASXDR1"),^TMP($JOB,"EASXDR")
+22 SET ^XTMP("EASXDR1",0)=$$FMADD^XLFDT($$NOW^XLFDT(),45)_U_$$NOW^XLFDT()_U_"EASXDR1 - DUPLICATE PATIENT RELATION MERGE"
+23 ; find 408.12 entries for FROM and TO records
+24 FOR X="IEN12FR","IEN12TO"
Begin DoDot:1
+25 SET REL="DFN"_$EXTRACT(X,6,7)
SET @X=""
+26 SET ARYNAM="^TMP($J,""EASXDR1"","""_$EXTRACT(X,6,7)_""")"
+27 SET ARYNAM2="^TMP($J,""EASXDR1"",""B"","""_$EXTRACT(X,6,7)_""")"
+28 FOR
SET @X=$ORDER(^DGPR(408.12,"B",@REL,@X))
if '@X
QUIT
Begin DoDot:2
+29 IF '$DATA(^DGPR(408.12,@X))
SET @ARYNAM@(@X)=(@REL)_"^NO 408.12 RECORD"
QUIT
+30 MERGE @ARYNAM@((@X))=^DGPR(408.12,@X)
+31 SET RELPNTR=$PIECE($GET(@ARYNAM@(@X,0)),"^",3)
+32 SET NAMIEN=$PIECE(RELPNTR,";")_","
SET NAMFIL=$PIECE(RELPNTR,";",2)
+33 IF NAMFIL="DPT("
SET NAMFIL=2
+34 IF '$TEST
SET NAMFIL=$TRANSLATE($PIECE(NAMFIL,"(",2),",")
+35 KILL NAME
+36 IF NAMIEN
IF NAMFIL
SET NAME=$$GET1^DIQ(NAMFIL,NAMIEN,.01)
+37 SET @ARYNAM@(@X,"NAME")=$GET(NAME)
+38 SET RELAT=$PIECE($GET(^DGPR(408.12,@X,0)),"^",2)
+39 SET @ARYNAM2@(RELAT,@X)=""
End DoDot:2
End DoDot:1
+40 ; merge duplicate records (if they exist)
+41 SET RELATE=""
SET OK=0
SET ERRNUM=0
+42 FOR
SET RELATE=$ORDER(@MRGROOT@("TO",RELATE))
if 'RELATE
QUIT
Begin DoDot:1
+43 SET MRGTOIEN=""
+44 FOR
SET MRGTOIEN=$ORDER(@MRGROOT@("TO",RELATE,MRGTOIEN))
if 'MRGTOIEN
QUIT
DO LOOP
End DoDot:1
+45 QUIT +$GET(OK)
LOOP ;
+1 MERGE ^TMP($JOB,"EASXDR","MRGTO",MRGTOIEN)=^DGPR(408.12,MRGTOIEN)
+2 SET MRGFRIEN=""
+3 FOR
SET MRGFRIEN=$ORDER(@MRGROOT@("FR",RELATE,MRGFRIEN))
if 'MRGFRIEN
QUIT
Begin DoDot:1
+4 ;do not update if FROM and TO iens are the same
if MRGFRIEN=MRGTOIEN
QUIT
+5 KILL ERROR
+6 IF RELATE'=1
Begin DoDot:2
+7 IF '$$MRGOTHR(MRGFRIEN,MRGTOIEN)
SET ERROR(MRGFRIEN)="DEPENDENT NAMES DO NOT MATCH"
KILL @MRGROOT@("FR",RELATE,MRGTOIEN)
QUIT
+8 IF '$$SSNMATCH(MRGFRIEN,MRGTOIEN)
Begin DoDot:3
+9 if $PIECE($GET(^DGPR(408.12,MRGFRIEN,0)),"^",2)'=$PIECE($GET(^DGPR(408.12,MRGTOIEN,0)),"^",2)
QUIT
+10 SET ERROR(MRGFRIEN)="DEPENDENT SSNS DO NOT MATCH"
+11 if '$GET(SILENT)
DO FAILED(MRGFRIEN,MRGTOIEN,$GET(ERROR(MRGFRIEN)))
+12 KILL @MRGROOT@("FR",RELATE,MRGTOIEN)
End DoDot:3
if $DATA(ERROR)
QUIT
End DoDot:2
if $DATA(ERROR)
QUIT
+13 MERGE ^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN)=^DGPR(408.12,MRGFRIEN)
+14 SET EFFDT=""
+15 FOR
SET EFFDT=$ORDER(^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN,"E","B",EFFDT))
if 'EFFDT
QUIT
Begin DoDot:2
+16 IF $DATA(^DGPR(408.12,MRGTOIEN,"E","B",EFFDT))
Begin DoDot:3
+17 SET ACTOK=$$CHKACT()
End DoDot:3
QUIT
+18 SET SUBIEN=+$ORDER(^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN,"E","B",EFFDT,""))
+19 if ('SUBIEN)!('$DATA(^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN,"E",SUBIEN)))
QUIT
+20 SET FRDATA=$GET(^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN,"E",SUBIEN,0))
+21 SET UPDMSG=$$UPDATE(MRGTOIEN,FRDATA,MRGFRIEN)
+22 IF 'UPDMSG
Begin DoDot:3
+23 SET ERROR(MRGFRIEN,SUBIEN)=$PIECE(UPDMSG,"^",2)
SET ERRNUM=ERRNUM+1
+24 if $PIECE(UPDMSG,"^",2)="The entry does not exist."
QUIT
+25 SET ^XTMP("EASXDR1","DATA",DFNFR,"ERROR - NOT MERGED",MRGFRIEN,SUBIEN)=$PIECE(UPDMSG,"^",2)
End DoDot:3
QUIT
End DoDot:2
+26 ;
IF '$DATA(ERROR)
IF $$REMOVE(MRGFRIEN,MRGTOIEN)
Begin DoDot:2
+27 SET OK=OK+1
+28 if '$GET(SILENT)
DO SUCCESS(MRGFRIEN,MRGTOIEN)
+29 KILL @MRGROOT@("FR",RELATE,MRGFRIEN)
+30 KILL @MRGROOT@("TO",RELATE,MRGFRIEN)
+31 IF $DATA(@MRGROOT@("TO",RELATE,MRGFRIEN))
KILL @MRGROOT@("TO",RELATE,MRGFRIEN)
+32 KILL ^TMP($JOB,"EASXDR")
+33 MERGE ^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN)=^DGPR(408.12,MRGFRIEN)
+34 MERGE ^TMP($JOB,"EASXDR","MRGTO",MRGTOIEN)=^DGPR(408.12,MRGTOIEN)
End DoDot:2
End DoDot:1
+35 QUIT
CHKACT() ; ensure both records contain the same active flag for eff. date
+1 NEW OK
+2 SET OK=1
+3 SET SUBIENFR=+$ORDER(^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN,"E","B",EFFDT,""))
+4 SET SUBIENTO=+$ORDER(^TMP($JOB,"EASXDR","MRGTO",MRGTOIEN,"E","B",EFFDT,""))
+5 SET ACTIVFR=$PIECE($GET(^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN,"E",SUBIENFR,0)),"^",2)
+6 SET ACTIVTO=$PIECE($GET(^TMP($JOB,"EASXDR","MRGTO",MRGTOIEN,"E",SUBIENTO,0)),"^",2)
+7 IF ACTIVFR'=ACTIVTO
Begin DoDot:1
+8 SET OK=0
+9 SET ERROR(MRGFRIEN,SUBIENFR)="'Active' flag does not match for effective date: "_$$FMTE^XLFDT(EFFDT)
SET ERRNUM=ERRNUM+1
+10 SET ^XTMP("EASXDR1","DATA",DFNFR,408.12,"ERROR - NOT MERGED",MRGFRIEN,SUBIENFR)=ERROR(MRGFRIEN,SUBIENFR)
+11 if '$GET(SILENT)
DO FAILED(MRGFRIEN,MRGTOIEN,$GET(ERROR(MRGFRIEN,SUBIENFR)))
+12 IF '$DATA(ERROR)
SET OK=1
End DoDot:1
QUIT OK
+13 QUIT OK
UPDATE(MRGTOIEN,FRDATA,MRGFRIEN) ;
+1 if ('MRGTOIEN)!(FRDATA="")
QUIT "0^RECORD NOT UPDATED - BAD INPUT DATA"
+2 NEW DIERR,IENS,FDA,MSGROOT,IENROOT,NAMEFR,NAMETO
+3 SET IENS="+1,"_MRGTOIEN_","
+4 SET FDA(408.1275,IENS,.01)=$PIECE(FRDATA,"^")
+5 SET FDA(408.1275,IENS,.02)=$PIECE(FRDATA,"^",2)
+6 SET FDA(408.1275,IENS,.03)=$PIECE(FRDATA,"^",3)
+7 SET FDA(408.1275,IENS,.04)=$PIECE(FRDATA,"^",4)
+8 SET NAMEFR=$GET(^TMP($JOB,"EASXDR1","FR",MRGFRIEN,"NAME"))
+9 IF NAMEFR=""
SET NAMEFR=$$GET1^DIQ(408.12,MRGFRIEN_",",.03,"E")
+10 SET NAMETO=$GET(^TMP($JOB,"EASXDR1","TO",MRGTOIEN,"NAME"))
+11 IF NAMETO=""
SET NAMEFR=$$GET1^DIQ(408.12,MRGTOIEN_",",.03,"E")
+12 DO UPDATE^DIE("","FDA","IENROOT","MSGROOT")
+13 IF '$DATA(DIERR)
Begin DoDot:1
+14 KILL @MRGROOT@("FR",RELATE,MRGFRIEN)
+15 KILL @MRGROOT@("TO",RELATE,MRGFRIEN)
+16 IF $DATA(@MRGROOT@("TO",RELATE,MRGFRIEN))
KILL @MRGROOT@("TO",RELATE,MRGFRIEN)
+17 KILL ^TMP($JOB,"EASXDR")
+18 MERGE ^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN)=^DGPR(408.12,MRGFRIEN)
+19 MERGE ^TMP($JOB,"EASXDR","MRGTO",MRGTOIEN)=^DGPR(408.12,MRGTOIEN)
End DoDot:1
QUIT "1^UPDATED "_$GET(IENROOT)
+20 QUIT "0^"_$GET(MSGROOT("DIERR",1,"TEXT",1))
DEL(ROOT,IEN) ;delete entries
+1 if 'IEN
QUIT "1^INVALID INPUT PARAMETER"
+2 NEW DA,DIK,MSG,X,Y,FILE
+3 SET FILE=$TRANSLATE($PIECE(ROOT,"(",2),",")
+4 ;default to error condition
SET MSG="1^DELETE ERROR "_ROOT_IEN
+5 MERGE ^XTMP("EASXDR1","DATA",DFNFR,FILE,IEN)=@(ROOT_IEN_")")
+6 SET DA=IEN
SET DIK=ROOT
DO ^DIK
DO IX^DIK
SET MSG="0^RECORD DELETED"
+7 QUIT MSG
MRGOTHR(MRGFRIEN,MRGTOIEN) ;
+1 if ('MRGFRIEN)!('MRGTOIEN)
QUIT 0
+2 NEW NAMEFR,NAMETO
+3 SET NAMEFR=$GET(^TMP($JOB,"EASXDR1","FR",MRGFRIEN,"NAME"))
+4 SET NAMETO=$GET(^TMP($JOB,"EASXDR1","TO",MRGTOIEN,"NAME"))
+5 ;ok to proceed with dependent merge
IF NAMEFR=NAMETO
QUIT 1
+6 ;different dependent - do not merge entries.
QUIT 0
SUCCESS(MRGFRIEN,MRGTOIEN) ;display message when merge is successful
+1 if ('$DATA(MRGFRIEN))!('$DATA(MRGTOIEN))
QUIT
+2 SET NAMEFR=$GET(^TMP($JOB,"EASXDR1","FR",MRGFRIEN,"NAME"))
+3 IF NAMEFR=""
SET NAMEFR=$$GET1^DIQ(408.12,MRGFRIEN_",",.03,"E")
+4 SET NAMETO=$GET(^TMP($JOB,"EASXDR1","TO",MRGTOIEN,"NAME"))
+5 IF NAMETO=""
SET NAMEFR=$$GET1^DIQ(408.12,MRGTOIEN_",",.03,"E")
+6 WRITE !!?2,MRGFRIEN," ",NAMEFR," was merged into ",MRGTOIEN," ",NAMETO
+7 QUIT
FAILED(MRGFRIEN,MRGTOIEN,MSG) ;display message when merge fails
+1 if ('$DATA(MRGFRIEN))!('$DATA(MRGTOIEN))!('$DATA(MSG))
QUIT
+2 NEW EFFDT1
+3 SET NAMEFR=$GET(^TMP($JOB,"EASXDR1","FR",+MRGFRIEN,"NAME"))
+4 IF NAMEFR=""
SET NAMEFR=$$GET1^DIQ(408.12,MRGFRIEN_",",.03,"E")
+5 SET NAMETO=$GET(^TMP($JOB,"EASXDR1","TO",+MRGTOIEN,"NAME"))
+6 IF NAMETO=""
SET NAMEFR=$$GET1^DIQ(408.12,MRGTOIEN_",",.03,"E")
+7 WRITE !!?2,MRGFRIEN," ",NAMEFR," could not be merged into ",MRGTOIEN," ",NAMETO,"."
+8 WRITE !?2,"Reason: ",$GET(MSG)
+9 SET EFFDT1=$GET(EFFDT)
+10 IF MSG["'Active' flag does not match"
Begin DoDot:1
+11 DO CHGACT^EASXDR(MRGFRIEN,MRGTOIEN,$GET(EFFDT))
+12 SET EFFDT=EFFDT1
+13 KILL ^TMP($JOB,"EASXDR1","FR",RELATE,MRGTOIEN)
End DoDot:1
+14 QUIT
REMOVE(MRGFRIEN,MRGTOIEN) ;delete and/or repoint "old" entries
+1 if ('MRGFRIEN)
QUIT "0^RECORD NOT DELETED - BAD INPUT DATA"
+2 IF '$DATA(MRGTOIEN)
NEW MRGTOIEN
SET MRGTOIEN="***DELETE***"
+3 ;from DFN is not present
IF '$DATA(DFNFR)
NEW DFNFR
SET DFNFR="DELETE"
+4 NEW VARPNT,MSG22,MSG21,ERROR,IEN40821,IEN40822,IEN40812,IEN40813
+5 NEW MSG12,MSG13,VARPNT2
+6 SET IEN40812=MRGFRIEN
+7 SET IEN40821=""
+8 SET ^XTMP("EASXDR1","DATA",DFNFR,408.12,MRGFRIEN)=$SELECT(MRGTOIEN:"RECORD MERGED INTO 408.12 IEN # "_MRGTOIEN,1:"RECORD DELETED")
+9 FOR
SET IEN40821=$ORDER(^DGMT(408.21,"C",IEN40812,IEN40821))
if 'IEN40821!($GET(ERROR))
QUIT
Begin DoDot:1
+10 SET IEN40822=""
+11 FOR
SET IEN40822=$ORDER(^DGMT(408.22,"AIND",IEN40821,IEN40822))
if 'IEN40822!($GET(ERROR))
QUIT
Begin DoDot:2
+12 SET MSG22=$$DEL("^DGMT(408.22,",IEN40822)
+13 IF MSG22
SET ERROR="1^"_IEN40822_"^"_$PIECE(MSG22,"^",2)_"^408.22 DELETE"
QUIT
+14 IF DFNFR="DELETE"
SET ^XTMP("EASXDR1","DATA",DFNFR,408.12,MRGFRIEN,"SEE 408.22",IEN40822)=""
End DoDot:2
+15 if $GET(ERROR)
QUIT
+16 SET MSG21=$$DEL("^DGMT(408.21,",IEN40821)
+17 IF MSG21
SET ERROR="1^"_IEN40821_"^"_$PIECE(MSG21,"^",2)_"^408.21 DELETE"
QUIT
+18 IF DFNFR="DELETE"
SET ^XTMP("EASXDR1","DATA",DFNFR,408.12,MRGFRIEN,"SEE 408.21",IEN40821)=""
End DoDot:1
+19 if $GET(ERROR)
QUIT "0^"_$PIECE(ERROR,"^",2,4)
+20 SET VARPNT=$PIECE($GET(^DGPR(408.12,IEN40812,0)),"^",3)
+21 SET IEN40813=""
if VARPNT["DGPR"
SET IEN40813=$PIECE(VARPNT,";")
+22 SET MSG12=$$DEL("^DGPR(408.12,",IEN40812)
+23 IF MSG12
QUIT "0^"_IEN40812_"^"_$PIECE(MSG12,"^",2)_"^408.12 DELETE"
+24 if 'IEN40813
QUIT "1^"_MRGFRIEN_" DELETED"
+25 SET VARPNT2=""
+26 ;ensure that the new record is not pointing to the same relation
+27 if MRGTOIEN
SET VARPNT2=$PIECE($GET(^DGPR(408.12,MRGTOIEN,0)),"^",3)
+28 if VARPNT=VARPNT2
QUIT "1^"_MRGFRIEN_" DELETED"
+29 SET MSG13=$$DEL("^DGPR(408.13,",IEN40813)
+30 IF DFNFR="DELETE"
SET ^XTMP("EASXDR1","DATA",DFNFR,408.12,MRGFRIEN,"SEE 408.13",IEN40813)=""
+31 if MSG13
QUIT "0^"_$PIECE(MSG13,"^",2)
+32 QUIT "1^"_MRGFRIEN_" DELETED"
SSNMATCH(FRIEN,TOIEN) ;
+1 NEW SSNFR,SSNTO
+2 DO FINDSSN^EASXDR(FRIEN,.SSNFR)
DO FINDSSN^EASXDR(TOIEN,.SSNTO)
+3 ;SSNs match
if SSNFR=SSNTO
QUIT 1
+4 ;use SSN of the 'merge to' record
if (SSNFR="UNKNOWN")!(SSNFR="")
QUIT 1
+5 QUIT 0
