- 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 Jan 18, 2025@02:57:09 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