XDRDMAIN.m

XDRDMAIN ;SF-IRMFO/IHS/OHPRD/JCM - MAIN DRIVER FOR DUPLICATE CHECKING SOFTWARE ;1/5/98  13:27

 ;;7.3;TOOLKIT;**23**;Apr 25, 1995

 ;;

START ;

 S XDRQFLG=0

 S XDRMAINI="DUP" D ^XDRMAINI G:XDRQFLG END

 I $$NEWERR^%ZTER() N $ETRAP,$ESTACK S $ETRAP="D ERR^XDRDMAIN"

 E  S X="ERR^XDRDMAIN",@^%ZOSF("TRAP")

 K ^XTMP("XDRERR",XDRFL) S ^XTMP("XDRERR",0)=($$FMADD^XLFDT(DT,30))_U_DT

 I $D(^VA(15.1,XDRFL,"APDTI")) D ^XDRDPDTI,COMPLETE G END

 D:$D(XDRDTYPE) @XDRDTYPE

 D COMPLETE ;I $P(^VA(15.1,XDRFL,0),U,2)="r" D COMPLETE

END D EOJ

 Q

ERR ;

 S XDRQERR=1

 S XDREMSG=$ZE

 S XDRQERR=1

 D ^%ZTER

 D COMPLETE

 G UNWIND^%ZTER

 ;

BASIC ;

 S XDRD("GL")=XDRGL_"XDRCD)"

 I $P(XDRD(0),U,6)]"" S XDRD("NEW GL")=XDRGL_""""_$P(XDRD(0),U,6)_""""_",XDRCD)"

 F XDRDI1=0:0 S $P(^VA(15.1,XDRFL,3),U)=$$NOW^XLFDT() S XDRCD=$O(@XDRD("GL")) Q:'XDRCD!($P(^VA(15.1,XDRFL,0),U,2)="h")!(XDRQFLG)  D POSDUPS D:$D(^TMP("XDRD",$J,XDRFL)) BCHECK D COUNT K:$D(XDRD("NEW GL")) @XDRD("NEW GL")

 I $P(^VA(15.1,XDRFL,0),U,2)="h" S XDRQFLG=1

 K XDRDI1

 Q

NEW ;

 ;I $P(XDRD(0),U,6)="" S XDRERR=17 D ^XDREMSG Q  ; COMMENTED OUT 1/5/98 JLI

 ;S XDRD("GL")=XDRGL_""""_$P(XDRD(0),U,6)_""""_",XDRCD)" ; COMMENTED OUT 1/5/98 JLI

 ;F XDRDI1=0:0 S $P(^VA(15.1,XDRFL,3),U)=$$NOW^XLFDT() S XDRCD=$O(@XDRD("GL")) Q:'XDRCD!($P(^VA(15.1,XDRFL,0),U,2)="h")!(XDRQFLG)  D POSDUPS D:$D(^TMP("XDRD",$J,XDRFL)) NCHECK K @XDRD("GL") D COUNT ; COMMENTED OUT 1/5/98 JLI

 ; ABOVE LINES USE A SPECIAL CROSS REFERENCE FOR NEW SEARCH, INSTEAD THE

 ; FOLLOWING LINES USE THE HIGHEST NUMBER PREVIOUSLY FOUND AS A POTENTIAL

 ; DUPLICATE AS THE STARTING POINT FOR THE NEW SEARCH.

 S XDRD("GL")=XDRGL_",XDRCD)" D  ; ADDED 1/5/98 JLI

 . N I,X,XGL

 . S XGL=$E(XDRGL,2,$L(XDRGL))

 . S I="",X=0

 . F  S I=$O(^VA(15,"B",I)) Q:I=""  I $P(I,";",2)=XGL,I>X S X=+I

 . S XDRCD=X

 G BASIC

 ;I $P(^VA(15.1,XDRFL,0),U,2)="h" S XDRQFLG=1 ; COMMENTED OUT 1/5/98

 ;K XDRDI1 ; COMMENTED OUT 1/5/98

 Q

POSDUPS ;

 K ^TMP("XDRD",$J,XDRFL)

 G:$D(^VA(15,"AFR",$P(XDRGL,U,2),XDRCD)) POSDUPSX

 ; *** Above I check to see if the record has already been merged.  I

 ; would have preferred to check some node within the file being

 ; checked since the Duplicate Record file may be purged, Fileman at

 ; some point in the future will provide a merged node.

 ; ***

 ; We will pass the variable XDRCD for them to then get the candidates

 ; Expect the routine to send back the possibles in

 ; ^TMP("XDRD",$J,XDRFL

 ;

 I '$D(@(XDRGL_XDRCD_",0)")) G POSDUPSX

 S X=$P(XDRD("COLLECTION ROUTINE"),U,2) X ^%ZOSF("TEST") K X I '$T S XDRERR=2 D ^XDREMSG G POSDUPSX

 D @XDRD("COLLECTION ROUTINE")

POSDUPSX Q

 ;

BCHECK ;

 F XDRCD2=0:0 S XDRCD2=$O(^TMP("XDRD",$J,XDRFL,XDRCD2)) Q:'XDRCD2!(XDRQFLG)  I $S(XDRDTYPE="BASIC":XDRCD2>XDRCD,1:1) D CHECK ; MODIFIED 1/5/98 JLI

 K ^TMP("XDRD",$J,XDRFL) F %=0:0 S %=$O(XDRCD(0)) Q:'%  K XDRCD(%)

 K %

 Q

 ;

NCHECK ;

 F XDRCD2=0:0 S XDRCD2=$O(^TMP("XDRD",$J,XDRFL,XDRCD2)) Q:'XDRCD2!(XDRQFLG)  S XDRD("GL2")=XDRGL_""""_$P(XDRD(0),U,6)_""""_",XDRCD2)" D:'$D(@XDRD("GL2")) CHECK

 K ^TMP("XDRD",$J,XDRFL) F %=0:0 S %=$O(XDRCD(0)) Q:'%  K XDRCD(%)

 K %,XDRD("GL2")

 Q

CHECK ;

 S XDRDMAIN("DUPFLG")=0

 I $D(^VA(15,"AFR",$P(XDRGL,U,2),XDRCD2)) G CHECKX

 S XDRDPAIR=$S(XDRCD<XDRCD2:XDRCD_U_XDRCD2,1:XDRCD2_U_XDRCD)

 F XDRDI="APOT","ANOT","AVDUP" I $D(^VA(15,XDRDI,$P(XDRGL,U,2),XDRDPAIR)) S:XDRDTYPE'="NEW" XDRDMAIN("DUPFLG")=1 D:XDRDTYPE="NEW" DIK

 K XDRDI,XDRDPAIR

 D:'XDRDMAIN("DUPFLG") ^XDRDUP

CHECKX ;

 Q

DIK ;

 ; If a new search type deletes any verified non-duplicates or potential

 ; duplicate entries involving the two records.

 S DA=$O(^VA(15,XDRDI,$P(XDRGL,U,2),XDRDPAIR,0)),DIK="^VA(15,"

 D ^DIK K DIK,DA

 Q

COUNT ;

 S XDRDCNT=XDRDCNT+1

 S DIE="^VA(15.1,",DA=XDRFL,DR=".07////"_XDRDCNT_";.08////"_XDRCD

 D ^DIE K DIE,DR,DA,D0

 Q

COMPLETE ;

 N DIE,DA,DR,%,X,Y

 S DIE="^VA(15.1,",DA=XDRFL

 S DR=$S($D(XDRQERR):".02////e",XDRQFLG:".02////h",1:".02////c")

 D NOW^%DTC

 S DR=DR_";.04////"_%

 S DR=DR_";.1////"_($P(^VA(15.1,XDRFL,0),U,10)+$$FMDIFF^XLFDT(%,$P(^(0),U,3),2))

 D ^DIE

 S $P(^VA(15.1,XDRFL,3),U)=""

 I $D(XDREMSG) S ^XTMP("XDRERR",XDRFL)=XDREMSG

 Q

EOJ ;

 S:$D(ZTQUEUED) ZTREQ="@"

 K XDRDSCOR,XDRDTEST,XDRDMAIN,XDRD,XDRDCNT,XDRCD,XDRCD2,XDRDTYPE

 K XDRFL,XDRGL,XDRDPDTI,XDRDPAIR,XDRQFLG,XDRDTYPE,XDRDNSTA

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XDRDMAIN   4348     printed  Mar 13, 2025@21:44:07                                                                                                                                                                                                    Page 2

XDRDMAIN  ;SF-IRMFO/IHS/OHPRD/JCM - MAIN DRIVER FOR DUPLICATE CHECKING SOFTWARE ;1/5/98  13:27

 +1       ;;7.3;TOOLKIT;**23**;Apr 25, 1995

 +2       ;;

START     ;

 +1        SET XDRQFLG=0

 +2        SET XDRMAINI="DUP"

           DO ^XDRMAINI

           if XDRQFLG

               GOTO END

 +3        IF $$NEWERR^%ZTER()

               NEW $ETRAP,$ESTACK

               SET $ETRAP="D ERR^XDRDMAIN"

 +4       IF '$TEST

               SET X="ERR^XDRDMAIN"

               SET @^%ZOSF("TRAP")

 +5        KILL ^XTMP("XDRERR",XDRFL)

           SET ^XTMP("XDRERR",0)=($$FMADD^XLFDT(DT,30))_U_DT

 +6        IF $DATA(^VA(15.1,XDRFL,"APDTI"))

               DO ^XDRDPDTI

               DO COMPLETE

               GOTO END

 +7        if $DATA(XDRDTYPE)

               DO @XDRDTYPE

 +8       ;I $P(^VA(15.1,XDRFL,0),U,2)="r" D COMPLETE

           DO COMPLETE

END        DO EOJ

 +1        QUIT 

ERR       ;

 +1        SET XDRQERR=1

 +2        SET XDREMSG=$ZE

 +3        SET XDRQERR=1

 +4        DO ^%ZTER

 +5        DO COMPLETE

 +6        GOTO UNWIND^%ZTER

 +7       ;

BASIC     ;

 +1        SET XDRD("GL")=XDRGL_"XDRCD)"

 +2        IF $PIECE(XDRD(0),U,6)]""

               SET XDRD("NEW GL")=XDRGL_""""_$PIECE(XDRD(0),U,6)_""""_",XDRCD)"

 +3        FOR XDRDI1=0:0

               SET $PIECE(^VA(15.1,XDRFL,3),U)=$$NOW^XLFDT()

               SET XDRCD=$ORDER(@XDRD("GL"))

               if 'XDRCD!($PIECE(^VA(15.1,XDRFL,0),U,2)="h")!(XDRQFLG)

                   QUIT 

               DO POSDUPS

               if $DATA(^TMP("XDRD",$JOB,XDRFL))

                   DO BCHECK

               DO COUNT

               if $DATA(XDRD("NEW GL"))

                   KILL @XDRD("NEW GL")

 +4        IF $PIECE(^VA(15.1,XDRFL,0),U,2)="h"

               SET XDRQFLG=1

 +5        KILL XDRDI1

 +6        QUIT 

NEW       ;

 +1       ;I $P(XDRD(0),U,6)="" S XDRERR=17 D ^XDREMSG Q  ; COMMENTED OUT 1/5/98 JLI

 +2       ;S XDRD("GL")=XDRGL_""""_$P(XDRD(0),U,6)_""""_",XDRCD)" ; COMMENTED OUT 1/5/98 JLI

 +3       ;F XDRDI1=0:0 S $P(^VA(15.1,XDRFL,3),U)=$$NOW^XLFDT() S XDRCD=$O(@XDRD("GL")) Q:'XDRCD!($P(^VA(15.1,XDRFL,0),U,2)="h")!(XDRQFLG)  D POSDUPS D:$D(^TMP("XDRD",$J,XDRFL)) NCHECK K @XDRD("GL") D COUNT ; COMMENTED OUT 1/5/98 JLI

 +4       ; ABOVE LINES USE A SPECIAL CROSS REFERENCE FOR NEW SEARCH, INSTEAD THE

 +5       ; FOLLOWING LINES USE THE HIGHEST NUMBER PREVIOUSLY FOUND AS A POTENTIAL

 +6       ; DUPLICATE AS THE STARTING POINT FOR THE NEW SEARCH.

 +7       ; ADDED 1/5/98 JLI

           SET XDRD("GL")=XDRGL_",XDRCD)"

           Begin DoDot:1

 +8            NEW I,X,XGL

 +9            SET XGL=$EXTRACT(XDRGL,2,$LENGTH(XDRGL))

 +10           SET I=""

               SET X=0

 +11           FOR 

                   SET I=$ORDER(^VA(15,"B",I))

                   if I=""

                       QUIT 

                   IF $PIECE(I,";",2)=XGL

                       IF I>X

                           SET X=+I

 +12           SET XDRCD=X

           End DoDot:1

 +13       GOTO BASIC

 +14      ;I $P(^VA(15.1,XDRFL,0),U,2)="h" S XDRQFLG=1 ; COMMENTED OUT 1/5/98

 +15      ;K XDRDI1 ; COMMENTED OUT 1/5/98

 +16       QUIT 

POSDUPS   ;

 +1        KILL ^TMP("XDRD",$JOB,XDRFL)

 +2        if $DATA(^VA(15,"AFR",$PIECE(XDRGL,U,2),XDRCD))

               GOTO POSDUPSX

 +3       ; *** Above I check to see if the record has already been merged.  I

 +4       ; would have preferred to check some node within the file being

 +5       ; checked since the Duplicate Record file may be purged, Fileman at

 +6       ; some point in the future will provide a merged node.

 +7       ; ***

 +8       ; We will pass the variable XDRCD for them to then get the candidates

 +9       ; Expect the routine to send back the possibles in

 +10      ; ^TMP("XDRD",$J,XDRFL

 +11      ;

 +12       IF '$DATA(@(XDRGL_XDRCD_",0)"))

               GOTO POSDUPSX

 +13       SET X=$PIECE(XDRD("COLLECTION ROUTINE"),U,2)

           XECUTE ^%ZOSF("TEST")

           KILL X

           IF '$TEST

               SET XDRERR=2

               DO ^XDREMSG

               GOTO POSDUPSX

 +14       DO @XDRD("COLLECTION ROUTINE")

POSDUPSX   QUIT 

 +1       ;

BCHECK    ;

 +1       ; MODIFIED 1/5/98 JLI

           FOR XDRCD2=0:0

               SET XDRCD2=$ORDER(^TMP("XDRD",$JOB,XDRFL,XDRCD2))

               if 'XDRCD2!(XDRQFLG)

                   QUIT 

               IF $SELECT(XDRDTYPE="BASIC":XDRCD2>XDRCD,1:1)

                   DO CHECK

 +2        KILL ^TMP("XDRD",$JOB,XDRFL)

           FOR %=0:0

               SET %=$ORDER(XDRCD(0))

               if '%

                   QUIT 

               KILL XDRCD(%)

 +3        KILL %

 +4        QUIT 

 +5       ;

NCHECK    ;

 +1        FOR XDRCD2=0:0

               SET XDRCD2=$ORDER(^TMP("XDRD",$JOB,XDRFL,XDRCD2))

               if 'XDRCD2!(XDRQFLG)

                   QUIT 

               SET XDRD("GL2")=XDRGL_""""_$PIECE(XDRD(0),U,6)_""""_",XDRCD2)"

               if '$DATA(@XDRD("GL2"))

                   DO CHECK

 +2        KILL ^TMP("XDRD",$JOB,XDRFL)

           FOR %=0:0

               SET %=$ORDER(XDRCD(0))

               if '%

                   QUIT 

               KILL XDRCD(%)

 +3        KILL %,XDRD("GL2")

 +4        QUIT 

CHECK     ;

 +1        SET XDRDMAIN("DUPFLG")=0

 +2        IF $DATA(^VA(15,"AFR",$PIECE(XDRGL,U,2),XDRCD2))

               GOTO CHECKX

 +3        SET XDRDPAIR=$SELECT(XDRCD<XDRCD2:XDRCD_U_XDRCD2,1:XDRCD2_U_XDRCD)

 +4        FOR XDRDI="APOT","ANOT","AVDUP"

               IF $DATA(^VA(15,XDRDI,$PIECE(XDRGL,U,2),XDRDPAIR))

                   if XDRDTYPE'="NEW"

                       SET XDRDMAIN("DUPFLG")=1

                   if XDRDTYPE="NEW"

                       DO DIK

 +5        KILL XDRDI,XDRDPAIR

 +6        if 'XDRDMAIN("DUPFLG")

               DO ^XDRDUP

CHECKX    ;

 +1        QUIT 

DIK       ;

 +1       ; If a new search type deletes any verified non-duplicates or potential

 +2       ; duplicate entries involving the two records.

 +3        SET DA=$ORDER(^VA(15,XDRDI,$PIECE(XDRGL,U,2),XDRDPAIR,0))

           SET DIK="^VA(15,"

 +4        DO ^DIK

           KILL DIK,DA

 +5        QUIT 

COUNT     ;

 +1        SET XDRDCNT=XDRDCNT+1

 +2        SET DIE="^VA(15.1,"

           SET DA=XDRFL

           SET DR=".07////"_XDRDCNT_";.08////"_XDRCD

 +3        DO ^DIE

           KILL DIE,DR,DA,D0

 +4        QUIT 

COMPLETE  ;

 +1        NEW DIE,DA,DR,%,X,Y

 +2        SET DIE="^VA(15.1,"

           SET DA=XDRFL

 +3        SET DR=$SELECT($DATA(XDRQERR):".02////e",XDRQFLG:".02////h",1:".02////c")

 +4        DO NOW^%DTC

 +5        SET DR=DR_";.04////"_%

 +6        SET DR=DR_";.1////"_($PIECE(^VA(15.1,XDRFL,0),U,10)+$$FMDIFF^XLFDT(%,$PIECE(^(0),U,3),2))

 +7        DO ^DIE

 +8        SET $PIECE(^VA(15.1,XDRFL,3),U)=""

 +9        IF $DATA(XDREMSG)

               SET ^XTMP("XDRERR",XDRFL)=XDREMSG

 +10       QUIT 

EOJ       ;

 +1        if $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        KILL XDRDSCOR,XDRDTEST,XDRDMAIN,XDRD,XDRDCNT,XDRCD,XDRCD2,XDRDTYPE

 +3        KILL XDRFL,XDRGL,XDRDPDTI,XDRDPAIR,XDRQFLG,XDRDTYPE,XDRDNSTA

 +4        QUIT