source: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDMAIN.m@ 1424

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