EASXDRPT ;ALB/AEG - DUP PT RELATION REPORT ;7-12-02
;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15,2001
;
RPT ; Option Entry Point.
D TEXT^EASXDRUT
W !
;
EN1 ; Device Handler.
N %ZIS
S %ZIS="QM" D ^%ZIS
I POP W !!,?5,"REPORT CANCELLED!",$C(7),! G STOPIT
I $D(IO("Q")) D QUEIT G STOPIT
I '$D(IO("Q")) D Q
.I $E(IOST,1,2)="C-" D WAIT^DICD,START Q
.E D START Q
Q
;
START ;
D SETUP^EASXDRUT
D INIT,FIND,PURGE
D PRINT^EASXRPT1
D QUIT
Q
;
INIT ; Setup scratch globals and initialize processing.
N EASA,EASB,EASC,EASAA,EASAB,EASAC,QUO
S QUO=""""
F EASA=1,2 D
.F EASB=1,2 D
..F EASC=1,2 D
...S EASAA=$S(EASA=1:"EASXDRPT",1:"DECEASED")
...S EASAB=$S(EASB=1:"CATC",1:"CATOTHER")
...S EASAC=$S(EASC=1:"NOCMOR",1:"CMORE")
...S ROOT(EASA,EASB,EASC)="^TMP("_QUO_EASAA_QUO_","_QUO_EASAB_QUO_","_QUO_EASAC_QUO_","_$J_")"
...Q
..Q
.Q
Q
;
FIND ; Search for potential dups in file #408.12
N EASDOD,EASMTS,EASSRC,SRC,REC12,EASPER,EASREL,EASACT,EASCNT
N NODE
S DFN=0
F S DFN=$O(^DGPR(408.12,"B",DFN)) Q:DFN'>0 D
.S EASDOD=$S($$GET1^DIQ(2,DFN_",",.351,"I")]"":2,1:1)
.S EASMTS=$S($P($$LST^DGMTU(DFN),U,4)="C":1,1:2)
.; The following call is supported via DBIA #2701
.S SRC=$$IFVCCI^MPIF001(DFN)
.S EASSRC=$S(SRC=1:2,1:1)
.S REC12=0
.F S REC12=$O(^DGPR(408.12,"B",DFN,REC12)) Q:REC12'>0 D
..S NODE=$G(^DGPR(408.12,REC12,0))
..S EASPER=$$GET1^DIQ(408.12,REC12_",",.03,"E")
..S:EASPER']"" EASPER="NO PERSON ENTRY"
..S EASREL=$$GET1^DIQ(408.12,REC12_",",.02,"E")
..S:EASREL']"" EASREL="NO RELATION ENTRY"
..S EASCNT=1
..I $D(DUPS(DFN,EASREL,EASPER)) D
...S EASCNT=$O(DUPS(DFN,EASREL,EASPER,""),-1)+1
..S DUPS(DFN,EASREL,EASPER,EASCNT)=REC12
..I EASREL="NO RELATION ENTRY" D Q
...S @ROOT(EASDOD,EASMTS,EASSRC)@("NO RELATION",DFN,EASCNT)=REC12_U_EASPER
..I EASPER="NO PERSON ENTRY" D Q
...S @ROOT(EASDOD,EASMTS,EASSRC)@("NO PERSON",DFN,EASCNT)=REC12_U_EASREL
..S EASACT=$$ACTIVE(REC12)
..S @ROOT(EASDOD,EASMTS,EASSRC)@(DFN,EASREL,EASCNT)=REC12_U_EASPER_U_EASACT
.K DUPS(DFN)
Q
;
ACTIVE(REC12) ; Is relation entry active ?
N RETV,EASSUB,EASTIEN,ACTF
S (RETV,ACTF)="",EASSUB=0
F S EASSUB=$O(^DGPR(408.12,REC12,"E",EASSUB)) Q:EASSUB'>0 D Q:$L(RETV,"~")>1
.S ACTF=$$GET1^DIQ(408.1275,EASSUB_","_REC12_",",".02")
.Q:ACTF']"" RETV
.S EASTIEN=$$GET1^DIQ(408.1275,EASSUB_","_REC12_",",.04,"I")
.S EASTIEN=$S(EASTIEN>0:$$GET1^DIQ(408.31,EASTIEN_",",.019,"I"),1:"")
.S EASTIEN=$S(EASTIEN>0:$$GET1^DIQ(408.33,EASTIEN_",",.01,"E"),1:"")
.S RETV=ACTF_"~"_EASTIEN_"~"_EASSUB
Q RETV
;
PURGE ; Purge non-duplicate from temp globals.
N AA,AB,AC
F AA=1,2 F AB=1,2 F AC=1,2 D MORE
Q
;
MORE ; Purge of non-dups continued.
N DFN,REL,LSTNUM,CNT,NODE2,CNT2
S (LNAME,DFN)=0
F S DFN=$O(@ROOT(AA,AB,AC)@(DFN)) Q:DFN'>0 D
.S REL=""
.F S REL=$O(@ROOT(AA,AB,AC)@(DFN,REL)) Q:REL']"" D
..S LSTNUM=$O(@ROOT(AA,AB,AC)@(DFN,REL,""),-1)
..I $D(@ROOT(AA,AB,AC)@(DFN,REL,LSTNUM,"E")) D Q
...S LNAME=$S($L(REL)>LNAME:$L(REL),1:LNAME)
..D NAME
..I $O(@ROOT(AA,AB,AC)@(DFN,REL,""))=LSTNUM D Q
...K @ROOT(AA,AB,AC)@(DFN,REL,LSTNUM)
..S CNT=""
..F S CNT=$O(@ROOT(AA,AB,AC)@(DFN,REL,CNT)) Q:CNT'>0 D
...S NODE2=@ROOT(AA,AB,AC)@(DFN,REL,CNT)
...I $P(NODE2,U,4)']"" D
....K @ROOT(AA,AB,AC)@(DFN,REL,CNT)
...I $P(NODE2,U,4)]"" D
....S LNAME=$S($L(REL)>LNAME:$L(REL),1:LNAME)
...Q
..Q
.Q
Q
;
NAME ; Check names
N CNT,CHKNAME,CNT2
S CNT=""
F S CNT=$O(@ROOT(AA,AB,AC)@(DFN,REL,CNT)) Q:CNT'>0 D
.S CHKNAME=$P($G(@ROOT(AA,AB,AC)@(DFN,REL,CNT)),U,2)
.I CHKNAME["MERGING" D
..S $P(@ROOT(AA,AB,AC)@(DFN,REL,CNT),U,4)="SHOULD BE MERGED"
.I $P($G(@ROOT(AA,AB,AC)@(DFN,REL,CNT)),U,4)]"" Q
.S CNT2=CNT
.F S CNT2=$O(@ROOT(AA,AB,AC)@(DFN,REL,CNT2)) Q:CNT2'>0 D
..I CHKNAME'=$P($G(@ROOT(AA,AB,AC)@(DFN,REL,CNT2)),U,2) Q
..S $P(@ROOT(AA,AB,AC)@(DFN,REL,CNT2),U,4)="SHOULD BE MERGED"
..S $P(@ROOT(AA,AB,AC)@(DFN,REL,CNT),U,4)="SHOULD BE MERGED"
Q
;
QUIT ; Cleanup and quit.
N A,B,C
F A=1,2 D
.F B=1,2 D
..F C=1,2 K @ROOT(A,B,C)
K DUPS,LNAME,POP,ROOT,ZTSK
K COL1,COL2,COL3,COL4,COL5,COL6,COL7,DAL,EQL,FSTP
Q
STOPIT ;
Q
QUEIT ; Que task
N ZTDESC,ZTRTN,ZTSAVE
S ZTDESC="EAS DUPLICATE PT REL REPORT",ZTRTN="START^EASXDRPT"
S ZTSAVE("*")=""
W !
D ^%ZTLOAD
I $G(ZTSK)>0 W !!,">>> Task Number #"_$G(ZTSK)_" queued. <<<",! H .5
D HOME^%ZIS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASXDRPT 4445 printed Sep 23, 2025@19:32 Page 2
EASXDRPT ;ALB/AEG - DUP PT RELATION REPORT ;7-12-02
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15,2001
+2 ;
RPT ; Option Entry Point.
+1 DO TEXT^EASXDRUT
+2 WRITE !
+3 ;
EN1 ; Device Handler.
+1 NEW %ZIS
+2 SET %ZIS="QM"
DO ^%ZIS
+3 IF POP
WRITE !!,?5,"REPORT CANCELLED!",$CHAR(7),!
GOTO STOPIT
+4 IF $DATA(IO("Q"))
DO QUEIT
GOTO STOPIT
+5 IF '$DATA(IO("Q"))
Begin DoDot:1
+6 IF $EXTRACT(IOST,1,2)="C-"
DO WAIT^DICD
DO START
QUIT
+7 IF '$TEST
DO START
QUIT
End DoDot:1
QUIT
+8 QUIT
+9 ;
START ;
+1 DO SETUP^EASXDRUT
+2 DO INIT
DO FIND
DO PURGE
+3 DO PRINT^EASXRPT1
+4 DO QUIT
+5 QUIT
+6 ;
INIT ; Setup scratch globals and initialize processing.
+1 NEW EASA,EASB,EASC,EASAA,EASAB,EASAC,QUO
+2 SET QUO=""""
+3 FOR EASA=1,2
Begin DoDot:1
+4 FOR EASB=1,2
Begin DoDot:2
+5 FOR EASC=1,2
Begin DoDot:3
+6 SET EASAA=$SELECT(EASA=1:"EASXDRPT",1:"DECEASED")
+7 SET EASAB=$SELECT(EASB=1:"CATC",1:"CATOTHER")
+8 SET EASAC=$SELECT(EASC=1:"NOCMOR",1:"CMORE")
+9 SET ROOT(EASA,EASB,EASC)="^TMP("_QUO_EASAA_QUO_","_QUO_EASAB_QUO_","_QUO_EASAC_QUO_","_$JOB_")"
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
FIND ; Search for potential dups in file #408.12
+1 NEW EASDOD,EASMTS,EASSRC,SRC,REC12,EASPER,EASREL,EASACT,EASCNT
+2 NEW NODE
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^DGPR(408.12,"B",DFN))
if DFN'>0
QUIT
Begin DoDot:1
+5 SET EASDOD=$SELECT($$GET1^DIQ(2,DFN_",",.351,"I")]"":2,1:1)
+6 SET EASMTS=$SELECT($PIECE($$LST^DGMTU(DFN),U,4)="C":1,1:2)
+7 ; The following call is supported via DBIA #2701
+8 SET SRC=$$IFVCCI^MPIF001(DFN)
+9 SET EASSRC=$SELECT(SRC=1:2,1:1)
+10 SET REC12=0
+11 FOR
SET REC12=$ORDER(^DGPR(408.12,"B",DFN,REC12))
if REC12'>0
QUIT
Begin DoDot:2
+12 SET NODE=$GET(^DGPR(408.12,REC12,0))
+13 SET EASPER=$$GET1^DIQ(408.12,REC12_",",.03,"E")
+14 if EASPER']""
SET EASPER="NO PERSON ENTRY"
+15 SET EASREL=$$GET1^DIQ(408.12,REC12_",",.02,"E")
+16 if EASREL']""
SET EASREL="NO RELATION ENTRY"
+17 SET EASCNT=1
+18 IF $DATA(DUPS(DFN,EASREL,EASPER))
Begin DoDot:3
+19 SET EASCNT=$ORDER(DUPS(DFN,EASREL,EASPER,""),-1)+1
End DoDot:3
+20 SET DUPS(DFN,EASREL,EASPER,EASCNT)=REC12
+21 IF EASREL="NO RELATION ENTRY"
Begin DoDot:3
+22 SET @ROOT(EASDOD,EASMTS,EASSRC)@("NO RELATION",DFN,EASCNT)=REC12_U_EASPER
End DoDot:3
QUIT
+23 IF EASPER="NO PERSON ENTRY"
Begin DoDot:3
+24 SET @ROOT(EASDOD,EASMTS,EASSRC)@("NO PERSON",DFN,EASCNT)=REC12_U_EASREL
End DoDot:3
QUIT
+25 SET EASACT=$$ACTIVE(REC12)
+26 SET @ROOT(EASDOD,EASMTS,EASSRC)@(DFN,EASREL,EASCNT)=REC12_U_EASPER_U_EASACT
End DoDot:2
+27 KILL DUPS(DFN)
End DoDot:1
+28 QUIT
+29 ;
ACTIVE(REC12) ; Is relation entry active ?
+1 NEW RETV,EASSUB,EASTIEN,ACTF
+2 SET (RETV,ACTF)=""
SET EASSUB=0
+3 FOR
SET EASSUB=$ORDER(^DGPR(408.12,REC12,"E",EASSUB))
if EASSUB'>0
QUIT
Begin DoDot:1
+4 SET ACTF=$$GET1^DIQ(408.1275,EASSUB_","_REC12_",",".02")
+5 if ACTF']""
QUIT RETV
+6 SET EASTIEN=$$GET1^DIQ(408.1275,EASSUB_","_REC12_",",.04,"I")
+7 SET EASTIEN=$SELECT(EASTIEN>0:$$GET1^DIQ(408.31,EASTIEN_",",.019,"I"),1:"")
+8 SET EASTIEN=$SELECT(EASTIEN>0:$$GET1^DIQ(408.33,EASTIEN_",",.01,"E"),1:"")
+9 SET RETV=ACTF_"~"_EASTIEN_"~"_EASSUB
End DoDot:1
if $LENGTH(RETV,"~")>1
QUIT
+10 QUIT RETV
+11 ;
PURGE ; Purge non-duplicate from temp globals.
+1 NEW AA,AB,AC
+2 FOR AA=1,2
FOR AB=1,2
FOR AC=1,2
DO MORE
+3 QUIT
+4 ;
MORE ; Purge of non-dups continued.
+1 NEW DFN,REL,LSTNUM,CNT,NODE2,CNT2
+2 SET (LNAME,DFN)=0
+3 FOR
SET DFN=$ORDER(@ROOT(AA,AB,AC)@(DFN))
if DFN'>0
QUIT
Begin DoDot:1
+4 SET REL=""
+5 FOR
SET REL=$ORDER(@ROOT(AA,AB,AC)@(DFN,REL))
if REL']""
QUIT
Begin DoDot:2
+6 SET LSTNUM=$ORDER(@ROOT(AA,AB,AC)@(DFN,REL,""),-1)
+7 IF $DATA(@ROOT(AA,AB,AC)@(DFN,REL,LSTNUM,"E"))
Begin DoDot:3
+8 SET LNAME=$SELECT($LENGTH(REL)>LNAME:$LENGTH(REL),1:LNAME)
End DoDot:3
QUIT
+9 DO NAME
+10 IF $ORDER(@ROOT(AA,AB,AC)@(DFN,REL,""))=LSTNUM
Begin DoDot:3
+11 KILL @ROOT(AA,AB,AC)@(DFN,REL,LSTNUM)
End DoDot:3
QUIT
+12 SET CNT=""
+13 FOR
SET CNT=$ORDER(@ROOT(AA,AB,AC)@(DFN,REL,CNT))
if CNT'>0
QUIT
Begin DoDot:3
+14 SET NODE2=@ROOT(AA,AB,AC)@(DFN,REL,CNT)
+15 IF $PIECE(NODE2,U,4)']""
Begin DoDot:4
+16 KILL @ROOT(AA,AB,AC)@(DFN,REL,CNT)
End DoDot:4
+17 IF $PIECE(NODE2,U,4)]""
Begin DoDot:4
+18 SET LNAME=$SELECT($LENGTH(REL)>LNAME:$LENGTH(REL),1:LNAME)
End DoDot:4
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
NAME ; Check names
+1 NEW CNT,CHKNAME,CNT2
+2 SET CNT=""
+3 FOR
SET CNT=$ORDER(@ROOT(AA,AB,AC)@(DFN,REL,CNT))
if CNT'>0
QUIT
Begin DoDot:1
+4 SET CHKNAME=$PIECE($GET(@ROOT(AA,AB,AC)@(DFN,REL,CNT)),U,2)
+5 IF CHKNAME["MERGING"
Begin DoDot:2
+6 SET $PIECE(@ROOT(AA,AB,AC)@(DFN,REL,CNT),U,4)="SHOULD BE MERGED"
End DoDot:2
+7 IF $PIECE($GET(@ROOT(AA,AB,AC)@(DFN,REL,CNT)),U,4)]""
QUIT
+8 SET CNT2=CNT
+9 FOR
SET CNT2=$ORDER(@ROOT(AA,AB,AC)@(DFN,REL,CNT2))
if CNT2'>0
QUIT
Begin DoDot:2
+10 IF CHKNAME'=$PIECE($GET(@ROOT(AA,AB,AC)@(DFN,REL,CNT2)),U,2)
QUIT
+11 SET $PIECE(@ROOT(AA,AB,AC)@(DFN,REL,CNT2),U,4)="SHOULD BE MERGED"
+12 SET $PIECE(@ROOT(AA,AB,AC)@(DFN,REL,CNT),U,4)="SHOULD BE MERGED"
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
QUIT ; Cleanup and quit.
+1 NEW A,B,C
+2 FOR A=1,2
Begin DoDot:1
+3 FOR B=1,2
Begin DoDot:2
+4 FOR C=1,2
KILL @ROOT(A,B,C)
End DoDot:2
End DoDot:1
+5 KILL DUPS,LNAME,POP,ROOT,ZTSK
+6 KILL COL1,COL2,COL3,COL4,COL5,COL6,COL7,DAL,EQL,FSTP
+7 QUIT
STOPIT ;
+1 QUIT
QUEIT ; Que task
+1 NEW ZTDESC,ZTRTN,ZTSAVE
+2 SET ZTDESC="EAS DUPLICATE PT REL REPORT"
SET ZTRTN="START^EASXDRPT"
+3 SET ZTSAVE("*")=""
+4 WRITE !
+5 DO ^%ZTLOAD
+6 IF $GET(ZTSK)>0
WRITE !!,">>> Task Number #"_$GET(ZTSK)_" queued. <<<",!
HANG .5
+7 DO HOME^%ZIS
+8 QUIT
