148 lines
5.3 KiB
Mathematica
148 lines
5.3 KiB
Mathematica
XDRDEDT ;SF-IRMFO/REM - EDIT STATUS FIELD IN FILE 15 ;09/22/99 11:12
|
|
;;7.3;TOOLKIT;**23,43**;Apr 25, 1995
|
|
EN ;;
|
|
N XDRFIL,X,X1,X2,N1,N2,XDRDELET
|
|
EN2 K DIE,DIC
|
|
S XDRFIL=$$FILE^XDRDPICK() Q:XDRFIL'>0 S XDRGLB=$G(^DIC(XDRFIL,0,"GL")) Q:XDRGLB=""
|
|
F D Q:DA'>0
|
|
. S DIC="^VA(15,",DIC(0)="AEQZ",DIC("S")="I $$SCRN^XDRDEDT(+Y,XDRGLB)"
|
|
. S DIC("A")="Select an Entry to "_$S($D(XDRDELET):"DELETE: ",1:"RESET TO POTENTIAL DUPLICATES: ")
|
|
. D ^DIC S DA=+Y Q:DA<0
|
|
. I $P(^VA(15,DA,0),U,4)<2 S X1=+^VA(15,DA,0),X2=+$P(^(0),U,2)
|
|
. E S X1=+$P(^VA(15,DA,0),U,2),X2=+^(0)
|
|
. S N1=$P(@(XDRGLB_X1_",0)"),U),N2=$P(@(XDRGLB_X2_",0)"),U)
|
|
. S N1=$$PEELNAM(N1),N2=$$PEELNAM(N2)
|
|
.W !!!," Duplicate Record File Entry ",DA," for the ",$P(^DIC(XDRFIL,0),U)," FILE"
|
|
. N XX D W !?10,X1,?20,N1,!?10,X2,?20,N2,!!?10,"Currently listed as ",XX,!!
|
|
. . N DIC,DIQ,DR,XDRQ
|
|
. . S DIC="^VA(15,",DIQ="XDRQ",DIQ(0)="E",DR=.03
|
|
. . D EN^DIQ1
|
|
. . S XX=$G(XDRQ(15,DA,.03,"E"))
|
|
. . Q
|
|
. S DIR(0)="Y",DIR("A")="Do you really want to "_$S($D(XDRDELET):"DELETE THIS DUPLICATE RECORD ENTRY",1:"RESET to POTENTIAL DUPLICATE"),DIR("B")="NO" D ^DIR Q:Y'>0
|
|
. D NAME(DA)
|
|
. I $D(XDRDELET) D
|
|
. . N DIK
|
|
. . S DIK="^VA(15," D ^DIK
|
|
. I '$D(XDRDELET) D
|
|
. . K DIE S DIE="^VA(15,",DR=".03///P;.04///@;.05///@;.07///@;.08///@;.1///@;.13///@;.14///@;" D ^DIE K DIE
|
|
. . S:$D(DUZ) $P(^VA(15,DA,0),U,12)=DUZ
|
|
. . K ^VA(15,DA,2)
|
|
. . K ^VA(15,DA,3)
|
|
. W !!," ",$S($D(XDRDELET):"Entry DELETED!",1:"Status RESET to POTENTIAL DUPLICATE RECORD."),!!,*7
|
|
. Q
|
|
K DA,DR,DIC,DIE
|
|
Q
|
|
SCRN(DA,GLOBAL) ;Screen for verified dup. or verified not dup.
|
|
I $P(^(0),U,5)>1 Q 0 ; But don't take merged or merge in progress!
|
|
I '$D(XDRDELET),$P(^(0),U,3)="P"!($P(^(0),U,3)="O") Q 0 ; DON'T NEED TO SET BACK
|
|
I (U_$P($P(^(0),U),";",2))'=GLOBAL Q 0 ; Take only the specified file
|
|
;I $P(^(0),U,3)="V" Q 1
|
|
;I $P(^(0),U,3)="N" Q 1
|
|
Q 1
|
|
;
|
|
NAME(DA) ;
|
|
N X,X1,X2,N,N1,N2
|
|
S X=^VA(15,DA,0),X1=+X,X2=+$P(X,U,2),X=$P($P(X,U),";",2)
|
|
S N1=$P($G(@(U_X_X1_",0)")),U)
|
|
S N2=$P($G(@(U_X_X2_",0)")),U)
|
|
S N=$$PEELNAM(N1)
|
|
I N'=N1 S $P(@(U_X_X1_",0)"),U)=N
|
|
S N=$$PEELNAM(N2)
|
|
I N'=N2 S $P(@(U_X_X2_",0)"),U)=N
|
|
Q
|
|
PEELNAM(NAME) ;
|
|
F Q:NAME'["MERGING INTO" S NAME=$P($P(NAME,"(",2,10),")",1,$L(NAME,")")-1)
|
|
Q NAME
|
|
;
|
|
DELETE ;
|
|
N XDRFIL,X,X1,X2,N1,N2,XDRDELET
|
|
S XDRDELET=1
|
|
D EN2
|
|
Q
|
|
;
|
|
LOOKUP(FILE) ; FIND PAIRS IN DUPLICATE RECORD FILE
|
|
N FILENAM,NAME,NAME1,NAME2,NAMEA,XDRDIC,DIR,Y,I,J,XDR1,IEN,N,X,FILID,IEN1
|
|
S FILENAM=$P(^DIC(FILE,0),U) I FILENAM="" G NOFILE
|
|
S XDRDIC=$G(^DIC(FILE,0,"GL")) I XDRDIC="" G NOFILE
|
|
S XDRDIC=";"_$E(XDRDIC,2,99)
|
|
;
|
|
LOOK1 K DIR S DIR("A")="Select "_FILENAM,DIR(0)="FO^2" D ^DIR K DIR ; GET PART OF A NAME
|
|
I X="" Q -1
|
|
I $D(DIRUT)!(Y="^") Q -1
|
|
;
|
|
; GET A LIST OF NAMES IN THE FILE STARTING WITH THE USERS INPUT AND WHICH HAVE AN IEN THAT IS
|
|
; IN THE DUPLICATE RECORD FILE
|
|
;
|
|
S NAME=$NA(^TMP($J,"XDRLIST")) K @NAME
|
|
D FIND^DIC(FILE,"","","",X,"","B^BS5^SSN","I $D(^VA(15,""B"",(Y_XDRDIC)))","",NAME)
|
|
;
|
|
S NAME1=$NA(@NAME@("DILIST"))
|
|
;
|
|
; NOW GO THROUGH THE LIST OF MATCHING NAMES AND CHECK FOR THOSE WHICH HAVE THE DESIRED STATUS
|
|
; USE THE DATA UNDER THE 2 NODE WHICH IS THE IEN
|
|
;
|
|
F I=0:0 S I=$O(@NAME1@(2,I)) Q:I'>0 S IEN=^(I) D
|
|
. S XDR1=IEN_XDRDIC
|
|
. F J=0:0 S J=$O(^VA(15,"B",XDR1,J)) Q:J'>0 I $P(^VA(15,J,0),U,3)="P" Q
|
|
. ; IF NOT AT LEAST ONE WITH THE DESIRED STATUS, THEN REMOVE IT FROM THE ARRAY
|
|
. I J'>0 F J=1,2,"ID" K @NAME1@(J,I)
|
|
. Q
|
|
;
|
|
S J=$O(@NAME1@(2,0)) I J'>0 G NONAME
|
|
;
|
|
S NAME2=$NA(^TMP($J,"XDRLI1")) K @NAME2
|
|
S N=0 F I=0:0 S I=$O(@NAME1@(1,I)) Q:I'>0 D
|
|
. S N=N+1
|
|
. S X=@NAME1@(1,I)_" [ien="_@NAME1@(2,I)_"]" F J=0:0 S J=$O(@NAME1@("ID",I,J)) Q:J'>0 S FILID(J)="" S X=X_" "_@NAME1@("ID",I,J)
|
|
. S @NAME2@(N)=X,@NAME2@(N,"IEN")=@NAME1@(2,I)
|
|
S X=$$ASK(NAME2) I X'>0 G NONAME
|
|
I N>1 W @NAME2@(X)
|
|
S IEN1=@NAME2@(X,"IEN")_XDRDIC K @NAME2,@NAME
|
|
S X=$$PAIR(IEN1,"FILID") I X'>0 G NONAME
|
|
Q X
|
|
;
|
|
PAIR(IENDIC,IDARR) ;
|
|
N FILE,IEN,NAME,XDRN,IEN2,XDRX1,XDRJ,XDRX
|
|
S NAME=$NA(^TMP($J,"XDRPAIR")) K @NAME
|
|
S FILE=+$P(@(U_$P(IENDIC,";",2)_"0)"),U,2),XDRN=0
|
|
F IEN=0:0 S IEN=$O(^VA(15,"B",IENDIC,IEN)) Q:IEN'>0 I $P(^VA(15,IEN,0),U,3)="P" D
|
|
. S XDRN=XDRN+1
|
|
. S XDRX=^VA(15,IEN,0)
|
|
. S IEN2=$P(XDRX,U) I IEN2=IENDIC S IEN2=$P(XDRX,U,2)
|
|
. S IEN2=+IEN2,IENS=IEN2_","
|
|
. S XDRX1=$$GET1^DIQ(FILE,IENS,.01)_" [iens="_IEN2_"]"
|
|
. F XDRJ=0:0 S XDRJ=$O(@IDARR@(XDRJ)) Q:XDRJ'>0 S XDRX1=XDRX1_" "_$$GET1^DIQ(FILE,IENS,XDRJ)
|
|
. S @NAME@(XDRN)=XDRX1,@NAME@(XDRN,"IEN")=IEN
|
|
I XDRN>1 W !!,"This entry is paired with more than one other record.",!,"Select which pair from the following list:",!
|
|
S XDRX=$$ASK(NAME) I XDRX>0 S XDRX=@NAME@(XDRX,"IEN")
|
|
K @NAME
|
|
Q XDRX
|
|
;
|
|
ASK(ARRAY) ;
|
|
N N,I,N1,NCHOICE
|
|
W !
|
|
S N=0 F I=0:0 S I=$O(@ARRAY@(I)) Q:I'>0 S N=N+1
|
|
I N'>1 S I=+$O(@ARRAY@(0)) W:I>0 @ARRAY@(I) Q I
|
|
I N>5 W "There are "_N_" choices.",!!
|
|
S N1=0,NCHOICE=0
|
|
F I=0:0 S I=$O(@ARRAY@(I)) Q:I'>0 S N1=N1+1 W !,N1,". ",@ARRAY@(I) I '(N1#5) S NCHOICE=$$ASKEM(N1,N) Q:NCHOICE Q:$D(DIRUT)
|
|
I 'NCHOICE,'$D(DIRUT) S NCHOICE=$$ASKEM(N1,N1)
|
|
Q NCHOICE
|
|
;
|
|
ASKEM(NCUR,NMAX) ;
|
|
N DIR,Y
|
|
W !! I NCUR<NMAX W !,"Choose from 1 to "_NCUR S DIR("A")="Or return to continue: ",DIR(0)="NO^1:"_NCUR
|
|
E S DIR("A")="Choose from 1 to "_NCUR,DIR(0)="N^1:"_NCUR
|
|
D ^DIR W ! I $D(DIRUT),'$D(DTOUT),'$D(DUOUT) K DIRUT
|
|
Q $S(Y>0:Y,1:0)
|
|
;
|
|
NOFILE ;
|
|
W !,"FILE ",FILE," NOT FOUND",$C(7),!!
|
|
Q -1
|
|
;
|
|
NONAME ;
|
|
W $C(7),"??"
|
|
G LOOK1
|
|
;
|