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 ---[H[J[2J[HXDRDMAIN 4348 printed Dec 13, 2024@02:39:04 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
