XDRDEDT ;SF-IRMFO/REM - EDIT STATUS FIELD IN FILE 15 ;10/10/08 13:38
;;7.3;TOOLKIT;**23,43,113**;Apr 25, 1995;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
EN ;;
N XDRFIL,X,X1,X2,N1,N2,XDRDELET,XDROSTAT
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"
. ; XT*7.3*113 changed to call $$GET1^DIQ instead of EN^DIQ
. S XDROSTAT=$$GET1^DIQ(15,DA_",",.03)
. W !?10,X1,?20,N1,!?10,X2,?20,N2,!!?10,"Currently listed as ",XDROSTAT,!!
. 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
. ; If PATIENT and previous status was VERIFIED, NOT A DUPLICATE, inactivate entry
. ; on the MPI DO NOT LINK file 985.28. - (new with XT*7.3*113)
. I XDROSTAT'="VERIFIED, NOT A DUPLICATE" Q
. Q:XDRFIL'=2
. ; Quit if routine ^MPIFDNL is not loaded
. S X="MPIFDNL" X ^%ZOSF("TEST") Q:'$T
. S X=^VA(15,DA,0)
. D CALLRPC^MPIFDNL(DUZ,DUZ(2),+X,+$P(X,U,2),1)
. 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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDEDT 5968 printed Dec 13, 2024@02:39 Page 2
XDRDEDT ;SF-IRMFO/REM - EDIT STATUS FIELD IN FILE 15 ;10/10/08 13:38
+1 ;;7.3;TOOLKIT;**23,43,113**;Apr 25, 1995;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
EN ;;
+1 NEW XDRFIL,X,X1,X2,N1,N2,XDRDELET,XDROSTAT
EN2 KILL DIE,DIC
+1 SET XDRFIL=$$FILE^XDRDPICK()
if XDRFIL'>0
QUIT
SET XDRGLB=$GET(^DIC(XDRFIL,0,"GL"))
if XDRGLB=""
QUIT
+2 FOR
Begin DoDot:1
+3 SET DIC="^VA(15,"
SET DIC(0)="AEQZ"
SET DIC("S")="I $$SCRN^XDRDEDT(+Y,XDRGLB)"
+4 SET DIC("A")="Select an Entry to "_$SELECT($DATA(XDRDELET):"DELETE: ",1:"RESET TO POTENTIAL DUPLICATES: ")
+5 DO ^DIC
SET DA=+Y
if DA<0
QUIT
+6 IF $PIECE(^VA(15,DA,0),U,4)<2
SET X1=+^VA(15,DA,0)
SET X2=+$PIECE(^(0),U,2)
+7 IF '$TEST
SET X1=+$PIECE(^VA(15,DA,0),U,2)
SET X2=+^(0)
+8 SET N1=$PIECE(@(XDRGLB_X1_",0)"),U)
SET N2=$PIECE(@(XDRGLB_X2_",0)"),U)
+9 SET N1=$$PEELNAM(N1)
SET N2=$$PEELNAM(N2)
+10 WRITE !!!," Duplicate Record File Entry ",DA," for the ",$PIECE(^DIC(XDRFIL,0),U)," FILE"
+11 ; XT*7.3*113 changed to call $$GET1^DIQ instead of EN^DIQ
+12 SET XDROSTAT=$$GET1^DIQ(15,DA_",",.03)
+13 WRITE !?10,X1,?20,N1,!?10,X2,?20,N2,!!?10,"Currently listed as ",XDROSTAT,!!
+14 SET DIR(0)="Y"
SET DIR("A")="Do you really want to "_$SELECT($DATA(XDRDELET):"DELETE THIS DUPLICATE RECORD ENTRY",1:"RESET to POTENTIAL DUPLICATE")
SET DIR("B")="NO"
+15 DO ^DIR
if Y'>0
QUIT
+16 DO NAME(DA)
+17 IF $DATA(XDRDELET)
Begin DoDot:2
+18 NEW DIK
+19 SET DIK="^VA(15,"
DO ^DIK
End DoDot:2
+20 IF '$DATA(XDRDELET)
Begin DoDot:2
+21 KILL DIE
SET DIE="^VA(15,"
SET DR=".03///P;.04///@;.05///@;.07///@;.08///@;.1///@;.13///@;.14///@;"
DO ^DIE
KILL DIE
+22 if $DATA(DUZ)
SET $PIECE(^VA(15,DA,0),U,12)=DUZ
+23 KILL ^VA(15,DA,2)
+24 KILL ^VA(15,DA,3)
End DoDot:2
+25 WRITE !!," ",$SELECT($DATA(XDRDELET):"Entry DELETED!",1:"Status RESET to POTENTIAL DUPLICATE RECORD."),!!,*7
+26 ; If PATIENT and previous status was VERIFIED, NOT A DUPLICATE, inactivate entry
+27 ; on the MPI DO NOT LINK file 985.28. - (new with XT*7.3*113)
+28 IF XDROSTAT'="VERIFIED, NOT A DUPLICATE"
QUIT
+29 if XDRFIL'=2
QUIT
+30 ; Quit if routine ^MPIFDNL is not loaded
+31 SET X="MPIFDNL"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+32 SET X=^VA(15,DA,0)
+33 DO CALLRPC^MPIFDNL(DUZ,DUZ(2),+X,+$PIECE(X,U,2),1)
+34 QUIT
End DoDot:1
if DA'>0
QUIT
+35 KILL DA,DR,DIC,DIE
+36 QUIT
SCRN(DA,GLOBAL) ;Screen for verified dup. or verified not dup.
+1 ; But don't take merged or merge in progress!
IF $PIECE(^(0),U,5)>1
QUIT 0
+2 ; DON'T NEED TO SET BACK
IF '$DATA(XDRDELET)
IF $PIECE(^(0),U,3)="P"!($PIECE(^(0),U,3)="O")
QUIT 0
+3 ; Take only the specified file
IF (U_$PIECE($PIECE(^(0),U),";",2))'=GLOBAL
QUIT 0
+4 ;I $P(^(0),U,3)="V" Q 1
+5 ;I $P(^(0),U,3)="N" Q 1
+6 QUIT 1
+7 ;
NAME(DA) ;
+1 NEW X,X1,X2,N,N1,N2
+2 SET X=^VA(15,DA,0)
SET X1=+X
SET X2=+$PIECE(X,U,2)
SET X=$PIECE($PIECE(X,U),";",2)
+3 SET N1=$PIECE($GET(@(U_X_X1_",0)")),U)
+4 SET N2=$PIECE($GET(@(U_X_X2_",0)")),U)
+5 SET N=$$PEELNAM(N1)
+6 IF N'=N1
SET $PIECE(@(U_X_X1_",0)"),U)=N
+7 SET N=$$PEELNAM(N2)
+8 IF N'=N2
SET $PIECE(@(U_X_X2_",0)"),U)=N
+9 QUIT
PEELNAM(NAME) ;
+1 FOR
if NAME'["MERGING INTO"
QUIT
SET NAME=$PIECE($PIECE(NAME,"(",2,10),")",1,$LENGTH(NAME,")")-1)
+2 QUIT NAME
+3 ;
DELETE ;
+1 NEW XDRFIL,X,X1,X2,N1,N2,XDRDELET
+2 SET XDRDELET=1
+3 DO EN2
+4 QUIT
+5 ;
LOOKUP(FILE) ; FIND PAIRS IN DUPLICATE RECORD FILE
+1 NEW FILENAM,NAME,NAME1,NAME2,NAMEA,XDRDIC,DIR,Y,I,J,XDR1,IEN,N,X,FILID,IEN1
+2 SET FILENAM=$PIECE(^DIC(FILE,0),U)
IF FILENAM=""
GOTO NOFILE
+3 SET XDRDIC=$GET(^DIC(FILE,0,"GL"))
IF XDRDIC=""
GOTO NOFILE
+4 SET XDRDIC=";"_$EXTRACT(XDRDIC,2,99)
+5 ;
LOOK1 ; GET PART OF A NAME
KILL DIR
SET DIR("A")="Select "_FILENAM
SET DIR(0)="FO^2"
DO ^DIR
KILL DIR
+1 IF X=""
QUIT -1
+2 IF $DATA(DIRUT)!(Y="^")
QUIT -1
+3 ;
+4 ; GET A LIST OF NAMES IN THE FILE STARTING WITH THE USERS INPUT AND WHICH HAVE AN IEN THAT IS
+5 ; IN THE DUPLICATE RECORD FILE
+6 ;
+7 SET NAME=$NAME(^TMP($JOB,"XDRLIST"))
KILL @NAME
+8 DO FIND^DIC(FILE,"","","",X,"","B^BS5^SSN","I $D(^VA(15,""B"",(Y_XDRDIC)))","",NAME)
+9 ;
+10 SET NAME1=$NAME(@NAME@("DILIST"))
+11 ;
+12 ; NOW GO THROUGH THE LIST OF MATCHING NAMES AND CHECK FOR THOSE WHICH HAVE THE DESIRED STATUS
+13 ; USE THE DATA UNDER THE 2 NODE WHICH IS THE IEN
+14 ;
+15 FOR I=0:0
SET I=$ORDER(@NAME1@(2,I))
if I'>0
QUIT
SET IEN=^(I)
Begin DoDot:1
+16 SET XDR1=IEN_XDRDIC
+17 FOR J=0:0
SET J=$ORDER(^VA(15,"B",XDR1,J))
if J'>0
QUIT
IF $PIECE(^VA(15,J,0),U,3)="P"
QUIT
+18 ; IF NOT AT LEAST ONE WITH THE DESIRED STATUS, THEN REMOVE IT FROM THE ARRAY
+19 IF J'>0
FOR J=1,2,"ID"
KILL @NAME1@(J,I)
+20 QUIT
End DoDot:1
+21 ;
+22 SET J=$ORDER(@NAME1@(2,0))
IF J'>0
GOTO NONAME
+23 ;
+24 SET NAME2=$NAME(^TMP($JOB,"XDRLI1"))
KILL @NAME2
+25 SET N=0
FOR I=0:0
SET I=$ORDER(@NAME1@(1,I))
if I'>0
QUIT
Begin DoDot:1
+26 SET N=N+1
+27 SET X=@NAME1@(1,I)_" [ien="_@NAME1@(2,I)_"]"
FOR J=0:0
SET J=$ORDER(@NAME1@("ID",I,J))
if J'>0
QUIT
SET FILID(J)=""
SET X=X_" "_@NAME1@("ID",I,J)
+28 SET @NAME2@(N)=X
SET @NAME2@(N,"IEN")=@NAME1@(2,I)
End DoDot:1
+29 SET X=$$ASK(NAME2)
IF X'>0
GOTO NONAME
+30 IF N>1
WRITE @NAME2@(X)
+31 SET IEN1=@NAME2@(X,"IEN")_XDRDIC
KILL @NAME2,@NAME
+32 SET X=$$PAIR(IEN1,"FILID")
IF X'>0
GOTO NONAME
+33 QUIT X
+34 ;
PAIR(IENDIC,IDARR) ;
+1 NEW FILE,IEN,NAME,XDRN,IEN2,XDRX1,XDRJ,XDRX
+2 SET NAME=$NAME(^TMP($JOB,"XDRPAIR"))
KILL @NAME
+3 SET FILE=+$PIECE(@(U_$PIECE(IENDIC,";",2)_"0)"),U,2)
SET XDRN=0
+4 FOR IEN=0:0
SET IEN=$ORDER(^VA(15,"B",IENDIC,IEN))
if IEN'>0
QUIT
IF $PIECE(^VA(15,IEN,0),U,3)="P"
Begin DoDot:1
+5 SET XDRN=XDRN+1
+6 SET XDRX=^VA(15,IEN,0)
+7 SET IEN2=$PIECE(XDRX,U)
IF IEN2=IENDIC
SET IEN2=$PIECE(XDRX,U,2)
+8 SET IEN2=+IEN2
SET IENS=IEN2_","
+9 SET XDRX1=$$GET1^DIQ(FILE,IENS,.01)_" [iens="_IEN2_"]"
+10 FOR XDRJ=0:0
SET XDRJ=$ORDER(@IDARR@(XDRJ))
if XDRJ'>0
QUIT
SET XDRX1=XDRX1_" "_$$GET1^DIQ(FILE,IENS,XDRJ)
+11 SET @NAME@(XDRN)=XDRX1
SET @NAME@(XDRN,"IEN")=IEN
End DoDot:1
+12 IF XDRN>1
WRITE !!,"This entry is paired with more than one other record.",!,"Select which pair from the following list:",!
+13 SET XDRX=$$ASK(NAME)
IF XDRX>0
SET XDRX=@NAME@(XDRX,"IEN")
+14 KILL @NAME
+15 QUIT XDRX
+16 ;
ASK(ARRAY) ;
+1 NEW N,I,N1,NCHOICE
+2 WRITE !
+3 SET N=0
FOR I=0:0
SET I=$ORDER(@ARRAY@(I))
if I'>0
QUIT
SET N=N+1
+4 IF N'>1
SET I=+$ORDER(@ARRAY@(0))
if I>0
WRITE @ARRAY@(I)
QUIT I
+5 IF N>5
WRITE "There are "_N_" choices.",!!
+6 SET N1=0
SET NCHOICE=0
+7 FOR I=0:0
SET I=$ORDER(@ARRAY@(I))
if I'>0
QUIT
SET N1=N1+1
WRITE !,N1,". ",@ARRAY@(I)
IF '(N1#5)
SET NCHOICE=$$ASKEM(N1,N)
if NCHOICE
QUIT
if $DATA(DIRUT)
QUIT
+8 IF 'NCHOICE
IF '$DATA(DIRUT)
SET NCHOICE=$$ASKEM(N1,N1)
+9 QUIT NCHOICE
+10 ;
ASKEM(NCUR,NMAX) ;
+1 NEW DIR,Y
+2 WRITE !!
IF NCUR<NMAX
WRITE !,"Choose from 1 to "_NCUR
SET DIR("A")="Or return to continue: "
SET DIR(0)="NO^1:"_NCUR
+3 IF '$TEST
SET DIR("A")="Choose from 1 to "_NCUR
SET DIR(0)="N^1:"_NCUR
+4 DO ^DIR
WRITE !
IF $DATA(DIRUT)
IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
KILL DIRUT
+5 QUIT $SELECT(Y>0:Y,1:0)
+6 ;
NOFILE ;
+1 WRITE !,"FILE ",FILE," NOT FOUND",$CHAR(7),!!
+2 QUIT -1
+3 ;
NONAME ;
+1 WRITE $CHAR(7),"??"
+2 GOTO LOOK1
+3 ;
