EASXDR ;ALB/BRM - ROUTINE TO MERGE ENTRIES DURING PATIENT MERGE; ; 5/10/02 9:27am
;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15, 2001
;
EN(ARRAY) ;Entry point called with the name of the array containing the
; from and to pointers of the record being merged. The array is
; formatted as follows:
; ARRAY(FROM_IEN,TO_IEN,"FROM_IEN;DPT(","TO_IEN;DPT(")=""
;
; The code in this routine will prevent duplicate dependent entries
; from being created when the from and to records are the same
;
N EASARY,IEN,DFNFR,DFNTO,IENFR,IENTO,OKTOMRG
F DFNFR=0:0 S DFNFR=$O(@ARRAY@(DFNFR)) Q:$G(DFNFR)'>0 D
.S DFNTO=$O(@ARRAY@(DFNFR,0))
.S IENFR=$O(@ARRAY@(DFNFR,DFNTO,0))
.S IENTO=$O(@ARRAY@(DFNFR,DFNTO,IENFR,0))
.;attempt to merge relation entries
.S OKTOMRG=$$CHKRELAT^EASXDR1(DFNFR,DFNTO,1)
Q
OPTION ; entry point from 'Fix Duplicate Patient Relations' menu option
N DTOUT,DUOUT,DIRUT,DIROUT,DA,DIR,DIC,X,Y,DFN,DGMSGF,SSN,VETNAM
S DGMSGF=1
S DIR(0)="408.12,.03"
S DIR("A")="Select Patient SSN"
S DIR("?")="Select the SSN of the patient whose Patient Relation entries should be merged."
D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
W !
I '+Y W !?2,Y(0)," Cannot be merged. Please select a new entry."
I $P(Y,";",2)["DGPR(408.13," D G:'$D(DFN) OPTION
.I '$D(^DGPR(408.12,"C",Y)) W !?2,Y(0)," Cannot be merged. Please select a new entry." Q
.S IEN12=$O(^DGPR(408.12,"C",Y,""))
.S DFN=$P($G(^DGPR(408.12,IEN12,0)),"^")
.S VETNAM=$P($G(^DPT(DFN,0)),"^")
.S SSN=$P($G(^DPT(DFN,0)),"^",9)
.W !?2,Y(0)," is not in the Patient (#2) file."
.W !!?2,"The following patient must be used to merge this entry:"
.W !?2,"SSN:",SSN,?20,"Patient Name:",VETNAM,!!
.K DIR,Y
.S DIR(0)="Y",DIR("B")="YES"
.S DIR("A")="Would you like to continue this merge using "_VETNAM
.S DIR("?",1)="Answer 'YES' if you would like to continue the merge process"
.S DIR("?",2)="using the displayed patient. This will merge all duplicate"
.S DIR("?")="Patient Relations associated with the selected patient."
.D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
.I 'Y K DFN Q
.S Y=DFN
S DFN=+Y
S MSG=$$CHKRELAT^EASXDR1(DFN,DFN,0)
I 'MSG W !?2,"No Patient Relation entries were merged for this patient.",!! G OPTION
W !?2,+MSG_" Patient Relation "_$S(+MSG=1:"entry was",1:"entries were")_" successfully merged."
W !!?2,"Data deleted during this merge will be stored for 10 days"
W !?2,"in the following global: ^XTMP(""EASXDR1"",""DATA"","_DFN_")",!!
G OPTION
Q
CHGACT(MRGFRIEN,MRGTOIEN,EFFDT) ;
N DIE,DIR,DIRUT,DTOUT,DUOUT,DIROUT,DIC,DA,DR,DIQ,X,Y,SSNFR,SSNTO
N ACTIVE
; display data about each record
D FINDSSN(MRGFRIEN,.SSNFR),FINDSSN(MRGTOIEN,.SSNTO)
W:SSNFR'="" !!,"SSN:"_SSNFR
S DIC="^DGPR(408.12,",DA=MRGFRIEN,DIQ(0)="R" D EN^DIQ
W:SSNTO'="" !,"SSN:"_SSNTO
S DIC="^DGPR(408.12,",DA=MRGTOIEN,DIQ(0)="R" D EN^DIQ
; ask user to enter the correct active flag for this date
S DIR(0)="Y"
S DIR("A")="Should the active flag be 'YES' or 'NO' for "_$$FMTE^XLFDT($G(EFFDT))
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q
S ACTIVE=Y
N IEN12,SUBIEN,ACTROOT,FDA,DIERR
F IEN12=MRGFRIEN,MRGTOIEN D
.S ACTROOT="^DGPR(408.12,"_IEN12_",""E"")"
.S SUBIEN=""
.Q:'$D(@ACTROOT@("B",EFFDT))
.F S SUBIEN=$O(@ACTROOT@("B",EFFDT,SUBIEN)) Q:'SUBIEN D
..I $P($G(@ACTROOT@(SUBIEN,0)),"^",2)=ACTIVE Q
..S FDA(408.1275,SUBIEN_","_IEN12_",",.02)=ACTIVE
..D FILE^DIE("K","FDA","DIERR")
; update arrays
K ^TMP($J,"EASXDR"),ERROR
M ^TMP($J,"EASXDR","MRGTO",MRGTOIEN)=^DGPR(408.12,MRGTOIEN)
M ^TMP($J,"EASXDR","MRGFR",MRGFRIEN)=^DGPR(408.12,MRGFRIEN)
;D LOOP^EASXDR1
Q
FINDSSN(IEN40812,SSN) ;find SSN associated with Patient Relation entry
N ROOT,NODE12,POINT
S SSN="UNKNOWN"
S NODE12=$G(^DGPR(408.12,IEN40812,0))
S POINT=$P(NODE12,"^",3)
S ROOT="^"_$P(POINT,";",2)_$P(POINT,";")_")"
I '$D(@ROOT@(0)) Q
S SSN=$P($G(@ROOT@(0)),"^",9)
Q
DELETE ; entry point from 'Delete Duplicate MT/Copay Dependents' menu option
N MSG,DTOUT,DUOUT,DIRUT,DIROUT,DA,DIR,DIC,X,Y,DFN,DGMSGF,SSN,VETNAM
S DGMSGF=1
S DIR(0)="408.12,.03"
S DIR("A")="Select MT/Copay Dependent to be deleted"
S DIR("?")="Select the SSN of the patient whose Patient Relation entries should be deleted."
D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
S IEN12=$O(^DGPR(408.12,"C",Y,""))
I 'IEN12 W !!?2,Y(0)," Cannot be deleted. Please select a new entry.",! G DELETE
S DIC="^DGPR(408.12,",DA=IEN12,DIQ(0)="R" D EN^DIQ
K DIR,Y,DTOUT,DIROUT,DIRUT,DUOUT
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Would you like to PERMANENTLY DELETE this record"
S DIR("?",1)="Answer 'YES' if you would like to continue the deletion process"
S DIR("?",2)="using the displayed patient. This process will permanently delete the"
S DIR("?")="408.13, 408.21, and 408.22 file entries associated with the selected patient."
D ^DIR
G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))!('Y) DELETE
S MSG=$$REMOVE^EASXDR1(IEN12,"")
I 'MSG W !?2,"No Patient Relation entries were deleted for this patient.",!! G DELETE
W !?2,+MSG_" Patient Relation "_$S(+MSG=1:"entry was",1:"entries were")_" successfully deleted."
W !!?2,"Data deleted during this process will be stored for 10 days"
W !?2,"in the following global: ^XTMP(""EASXDR1"",""DATA"",""DELETE"",408.12,"_IEN12_")",!!
G DELETE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASXDR 5400 printed Sep 23, 2025@19:31:58 Page 2
EASXDR ;ALB/BRM - ROUTINE TO MERGE ENTRIES DURING PATIENT MERGE; ; 5/10/02 9:27am
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15, 2001
+2 ;
EN(ARRAY) ;Entry point called with the name of the array containing the
+1 ; from and to pointers of the record being merged. The array is
+2 ; formatted as follows:
+3 ; ARRAY(FROM_IEN,TO_IEN,"FROM_IEN;DPT(","TO_IEN;DPT(")=""
+4 ;
+5 ; The code in this routine will prevent duplicate dependent entries
+6 ; from being created when the from and to records are the same
+7 ;
+8 NEW EASARY,IEN,DFNFR,DFNTO,IENFR,IENTO,OKTOMRG
+9 FOR DFNFR=0:0
SET DFNFR=$ORDER(@ARRAY@(DFNFR))
if $GET(DFNFR)'>0
QUIT
Begin DoDot:1
+10 SET DFNTO=$ORDER(@ARRAY@(DFNFR,0))
+11 SET IENFR=$ORDER(@ARRAY@(DFNFR,DFNTO,0))
+12 SET IENTO=$ORDER(@ARRAY@(DFNFR,DFNTO,IENFR,0))
+13 ;attempt to merge relation entries
+14 SET OKTOMRG=$$CHKRELAT^EASXDR1(DFNFR,DFNTO,1)
End DoDot:1
+15 QUIT
OPTION ; entry point from 'Fix Duplicate Patient Relations' menu option
+1 NEW DTOUT,DUOUT,DIRUT,DIROUT,DA,DIR,DIC,X,Y,DFN,DGMSGF,SSN,VETNAM
+2 SET DGMSGF=1
+3 SET DIR(0)="408.12,.03"
+4 SET DIR("A")="Select Patient SSN"
+5 SET DIR("?")="Select the SSN of the patient whose Patient Relation entries should be merged."
+6 DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
QUIT
+7 WRITE !
+8 IF '+Y
WRITE !?2,Y(0)," Cannot be merged. Please select a new entry."
+9 IF $PIECE(Y,";",2)["DGPR(408.13,"
Begin DoDot:1
+10 IF '$DATA(^DGPR(408.12,"C",Y))
WRITE !?2,Y(0)," Cannot be merged. Please select a new entry."
QUIT
+11 SET IEN12=$ORDER(^DGPR(408.12,"C",Y,""))
+12 SET DFN=$PIECE($GET(^DGPR(408.12,IEN12,0)),"^")
+13 SET VETNAM=$PIECE($GET(^DPT(DFN,0)),"^")
+14 SET SSN=$PIECE($GET(^DPT(DFN,0)),"^",9)
+15 WRITE !?2,Y(0)," is not in the Patient (#2) file."
+16 WRITE !!?2,"The following patient must be used to merge this entry:"
+17 WRITE !?2,"SSN:",SSN,?20,"Patient Name:",VETNAM,!!
+18 KILL DIR,Y
+19 SET DIR(0)="Y"
SET DIR("B")="YES"
+20 SET DIR("A")="Would you like to continue this merge using "_VETNAM
+21 SET DIR("?",1)="Answer 'YES' if you would like to continue the merge process"
+22 SET DIR("?",2)="using the displayed patient. This will merge all duplicate"
+23 SET DIR("?")="Patient Relations associated with the selected patient."
+24 DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
QUIT
+25 IF 'Y
KILL DFN
QUIT
+26 SET Y=DFN
End DoDot:1
if '$DATA(DFN)
GOTO OPTION
+27 SET DFN=+Y
+28 SET MSG=$$CHKRELAT^EASXDR1(DFN,DFN,0)
+29 IF 'MSG
WRITE !?2,"No Patient Relation entries were merged for this patient.",!!
GOTO OPTION
+30 WRITE !?2,+MSG_" Patient Relation "_$SELECT(+MSG=1:"entry was",1:"entries were")_" successfully merged."
+31 WRITE !!?2,"Data deleted during this merge will be stored for 10 days"
+32 WRITE !?2,"in the following global: ^XTMP(""EASXDR1"",""DATA"","_DFN_")",!!
+33 GOTO OPTION
+34 QUIT
CHGACT(MRGFRIEN,MRGTOIEN,EFFDT) ;
+1 NEW DIE,DIR,DIRUT,DTOUT,DUOUT,DIROUT,DIC,DA,DR,DIQ,X,Y,SSNFR,SSNTO
+2 NEW ACTIVE
+3 ; display data about each record
+4 DO FINDSSN(MRGFRIEN,.SSNFR)
DO FINDSSN(MRGTOIEN,.SSNTO)
+5 if SSNFR'=""
WRITE !!,"SSN:"_SSNFR
+6 SET DIC="^DGPR(408.12,"
SET DA=MRGFRIEN
SET DIQ(0)="R"
DO EN^DIQ
+7 if SSNTO'=""
WRITE !,"SSN:"_SSNTO
+8 SET DIC="^DGPR(408.12,"
SET DA=MRGTOIEN
SET DIQ(0)="R"
DO EN^DIQ
+9 ; ask user to enter the correct active flag for this date
+10 SET DIR(0)="Y"
+11 SET DIR("A")="Should the active flag be 'YES' or 'NO' for "_$$FMTE^XLFDT($GET(EFFDT))
+12 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+13 SET ACTIVE=Y
+14 NEW IEN12,SUBIEN,ACTROOT,FDA,DIERR
+15 FOR IEN12=MRGFRIEN,MRGTOIEN
Begin DoDot:1
+16 SET ACTROOT="^DGPR(408.12,"_IEN12_",""E"")"
+17 SET SUBIEN=""
+18 if '$DATA(@ACTROOT@("B",EFFDT))
QUIT
+19 FOR
SET SUBIEN=$ORDER(@ACTROOT@("B",EFFDT,SUBIEN))
if 'SUBIEN
QUIT
Begin DoDot:2
+20 IF $PIECE($GET(@ACTROOT@(SUBIEN,0)),"^",2)=ACTIVE
QUIT
+21 SET FDA(408.1275,SUBIEN_","_IEN12_",",.02)=ACTIVE
+22 DO FILE^DIE("K","FDA","DIERR")
End DoDot:2
End DoDot:1
+23 ; update arrays
+24 KILL ^TMP($JOB,"EASXDR"),ERROR
+25 MERGE ^TMP($JOB,"EASXDR","MRGTO",MRGTOIEN)=^DGPR(408.12,MRGTOIEN)
+26 MERGE ^TMP($JOB,"EASXDR","MRGFR",MRGFRIEN)=^DGPR(408.12,MRGFRIEN)
+27 ;D LOOP^EASXDR1
+28 QUIT
FINDSSN(IEN40812,SSN) ;find SSN associated with Patient Relation entry
+1 NEW ROOT,NODE12,POINT
+2 SET SSN="UNKNOWN"
+3 SET NODE12=$GET(^DGPR(408.12,IEN40812,0))
+4 SET POINT=$PIECE(NODE12,"^",3)
+5 SET ROOT="^"_$PIECE(POINT,";",2)_$PIECE(POINT,";")_")"
+6 IF '$DATA(@ROOT@(0))
QUIT
+7 SET SSN=$PIECE($GET(@ROOT@(0)),"^",9)
+8 QUIT
DELETE ; entry point from 'Delete Duplicate MT/Copay Dependents' menu option
+1 NEW MSG,DTOUT,DUOUT,DIRUT,DIROUT,DA,DIR,DIC,X,Y,DFN,DGMSGF,SSN,VETNAM
+2 SET DGMSGF=1
+3 SET DIR(0)="408.12,.03"
+4 SET DIR("A")="Select MT/Copay Dependent to be deleted"
+5 SET DIR("?")="Select the SSN of the patient whose Patient Relation entries should be deleted."
+6 DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
QUIT
+7 SET IEN12=$ORDER(^DGPR(408.12,"C",Y,""))
+8 IF 'IEN12
WRITE !!?2,Y(0)," Cannot be deleted. Please select a new entry.",!
GOTO DELETE
+9 SET DIC="^DGPR(408.12,"
SET DA=IEN12
SET DIQ(0)="R"
DO EN^DIQ
+10 KILL DIR,Y,DTOUT,DIROUT,DIRUT,DUOUT
+11 SET DIR(0)="Y"
SET DIR("B")="NO"
+12 SET DIR("A")="Would you like to PERMANENTLY DELETE this record"
+13 SET DIR("?",1)="Answer 'YES' if you would like to continue the deletion process"
+14 SET DIR("?",2)="using the displayed patient. This process will permanently delete the"
+15 SET DIR("?")="408.13, 408.21, and 408.22 file entries associated with the selected patient."
+16 DO ^DIR
+17 if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))!('Y)
GOTO DELETE
+18 SET MSG=$$REMOVE^EASXDR1(IEN12,"")
+19 IF 'MSG
WRITE !?2,"No Patient Relation entries were deleted for this patient.",!!
GOTO DELETE
+20 WRITE !?2,+MSG_" Patient Relation "_$SELECT(+MSG=1:"entry was",1:"entries were")_" successfully deleted."
+21 WRITE !!?2,"Data deleted during this process will be stored for 10 days"
+22 WRITE !?2,"in the following global: ^XTMP(""EASXDR1"",""DATA"",""DELETE"",408.12,"_IEN12_")",!!
+23 GOTO DELETE
+24 QUIT
