DIKK ;SFISC/MKO-CHECK KEY INTEGRITY ;9:14 AM 23 Feb 1999
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
INTEG(DIFILE,DIREC,DIFLD,DIKKEY,DICTRL,DIKPROC) ;
N DA,DIF,DIKERR,DIKFIL,DIKKQUIT,DIMF,DIROOT,DITAR
;
;If called as an extrinsic, manipulate DICTRL
S DIKPROC=$G(DIKPROC)
I 'DIKPROC N DICTRL1,DIKKTAR M DICTRL1=DICTRL S DICTRL("TAR")="DIKKTAR"
;
S DIF=$E("D",$G(DICTRL)'["d")
I DIF["D",'$D(DIQUIET) N DIQUIET S DIQUIET=1
I DIF["D",'$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
;
;Check input params, initialize variables, clean output array
D INIT^DIKK2 G:$G(DIKERR)]"" MOVE
I 'DIKPROC S:$G(DICTRL)'["Q" DICTRL=$G(DICTRL)_"Q"
;
;Load key info into ^TMP("DIKK",$J), and multiple info into DIMF
K ^TMP("DIKK",$J)
I $G(DIKKEY)?."^" D
. I $G(DIFLD) D
.. D LOADFLD^DIKK1(DIKFIL,DIFLD)
. E D LOADALL^DIKK1(DIKFIL,$E("s",$G(DICTRL)["s"),.DIMF)
E D LOADKEY^DIKK1(DIKKEY)
G:'$O(^TMP("DIKK",$J,0)) EXIT
D:DIKFIL'=DIFILE SBINFO^DIKCU(DIKFIL,.DIMF)
;
;Check one or all records in file DIFILE
I DA D
. D CHECK(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
E D CHECKALL(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
;
EXIT ;Cleanup ^TMP and quit
K ^TMP("DIKK",$J)
;
MOVE ;Move error messages if necessary
I DIF["D",$G(DIERR),$G(DICTRL("MSG"))]"" D CALLOUT^DIEFU(DICTRL("MSG"))
I 'DIKPROC K DICTRL M DICTRL=DICTRL1 Q $D(DIKKTAR)=0&($G(DIKERR)="")
Q
;
CHECK(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Check one record
I $D(^TMP("DIKK",$J,"UIR",DIFILE)) D CHECK^DIKK2(DIFILE,.DA,DITAR,.DIKKQUIT) Q:$G(DIKKQUIT)
D:$D(DIMF(DIFILE)) CHECKSUB(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
Q
;
CHECKALL(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Check all records
I $D(^TMP("DIKK",$J,"UI",DIFILE)) D UICHK(DIFILE,.DA,DITAR,.DIKKQUIT) Q:$G(DIKKQUIT)
I '$D(^TMP("DIKK",$J,DIFILE)),'$D(DIMF(DIFILE)) Q
;
;Loop through all records in file, check for null key fields
S DA=0 F S DA=$O(@DIROOT@(DA)) Q:DA'=+DA D Q:$G(DIKKQUIT)
. I $D(^TMP("DIKK",$J,DIFILE)) D NULLCHK(DIFILE,.DA,DITAR,.DIKKQUIT) Q:$G(DIKKQUIT)
. D:$D(DIMF(DIFILE)) CHECKSUB(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
Q
;
CHECKSUB(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Process all records in subfiles
N DIMULTF,DISBFILE,DISBROOT
D PUSHDA^DIKCU(.DA)
;
;Loop through the DIMF array and make recursive call to check all
;subrecords
S DIMULTF=0 F S DIMULTF=$O(DIMF(DIFILE,DIMULTF)) Q:'DIMULTF D Q:$G(DIKKQUIT)
. S DISBROOT=$NA(@DIROOT@(DA(1),DIMF(DIFILE,DIMULTF))) Q:'$D(@DISBROOT)
. S DISBFILE=DIMF(DIFILE,DIMULTF,0)
. D CHECKALL(DISBFILE,.DA,DISBROOT,.DIMF,DITAR,.DIKKQUIT)
;
D POPDA^DIKCU(.DA)
Q
;
NULLCHK(KFIL,DA,DITAR,DIKKQUIT) ;Check whether any of the key fields at
;KFIL file level are null for a given record.
N FIL,FLD,IENS,LDIF,X
;
S FIL=0 F S FIL=$O(^TMP("DIKK",$J,KFIL,FIL)) Q:'FIL D Q:$G(DIKKQUIT)
. S LDIF=+$G(^TMP("DIKK",$J,KFIL,FIL))
. S FLD=0 F S FLD=$O(^TMP("DIKK",$J,KFIL,FIL,FLD)) Q:'FLD D Q:$G(DIKKQUIT)
.. X ^TMP("DIKK",$J,KFIL,FIL,FLD) Q:X]""
.. S IENS=$$IENS(.DA)
.. S:LDIF IENS=$P(IENS,",",LDIF+1,999)
.. D SETN(FIL,IENS,FLD,DITAR,.DIKKQUIT)
Q
;
UICHK(FILE,DA,OUT,DIKKQUIT) ;Walk through uniqueness index and check for duplicates
N IX0,IX1,IX2,IXV1,IXV2,KEY,KFIL,LDIF,NS,S,SS,UI
;
S UI=0 F S UI=$O(^TMP("DIKK",$J,"UI",FILE,UI)) Q:'UI D Q:$G(DIKKQUIT)
. ;Get info about uniqueness index
. S KEY=$G(^TMP("DIKK",$J,"UI",FILE,UI))
. I $P(KEY,U,2)]"" D
.. S KFIL=$P(KEY,U,2),LDIF=$P(KEY,U,3),KEY=$P(KEY,U)
.. S IX0=^TMP("DIKK",$J,"UI",FILE,UI,"UIR") M SS=^("SS")
. E D
.. D XRINFO^DIKCU2(UI,"",.LDIF,"",.KFIL,.IX0,.SS)
.. ;
.. ;Remove elements from the SS array that have no max length.
.. ;For those that have max length, set SS(S)=data extraction code
.. S S=0 F S S=$O(SS(S)) Q:'S D
... I '$P(SS(S),U,3) K SS(S) Q
... S SS(S)=^TMP("DIKK",$J,KFIL,$P(SS(S),U),$P(SS(S),U,2))
.. ;
.. ;Remember info for next time
. S KEY=+KEY
. S ^TMP("DIKK",$J,"UI",FILE,UI)=KEY_U_KFIL_U_LDIF,^(UI,"UIR")=IX0
. M ^TMP("DIKK",$J,"UI",FILE,UI,"SS")=SS
. ;
. ;If necessary, push the DA array
. D:LDIF PUSHDA^DIKCU(.DA,LDIF)
. ;
. ;Walk down the uniqueness index and look for duplicates
. S (IX0,IX1,IX2)=$NA(@IX0),NS=$QL(IX0)
. F S IX2=$Q(@IX2) Q:IX2="" Q:$NA(@IX2,NS)'=IX0 D Q:$G(DIKKQUIT)
.. S IXV1=$NA(@IX1,NS+SS),IXV2=$NA(@IX2,NS+SS)
.. I IXV1'=IXV2 S IX1=IX2 Q
.. D DUPL(KEY,UI,FILE,KFIL,.DA,IX1,IX2,IXV1,NS,.SS,.DIKKQUIT)
.. S (IX1,IX2)=$NA(@IXV1@("~"))
. ;
. ;Pop the DA array
. D:LDIF POPDA^DIKCU(.DA,LDIF)
Q
;
DUPL(KEY,UI,UIFIL,UIRFIL,DA,IX1,IX2,IXV,NS,SS,DIKKQUIT) ;Process duplicate
;indexes
N DUPL,IENSDONE,I,IENS1,IENS2,L,ML,NEXTIX1,S,V1,X
;
;Set ML(subsc)=SS(subsc) for those subscripts that are >= maxlength
S S=0
F S S=$O(SS(S)) Q:'S S:$L($QS(IXV,NS+S))'<$P(SS(S),U,3) ML(S)=SS(S)
;
DLOOP ;Compare IX1 with IX2 and subsequent indexes
K NEXTIX1
;
;Set iens and DA array for 1st index
S IENS1=$E(IX1,$L(IXV)+1,$L(IX1)-1),L=$L(IENS1,",")
S DA=$P(IENS1,",",L) F I=1:1:L-1 S DA(I)=$P(IENS1,",",L-I)
S IENS1=$$IENS(.DA)
;
;If any subsc >= maxlen, set V1(subsc) = value array for 1st index
I $D(ML) K V1 S S=0 F S S=$O(ML(S)) Q:'S X ML(S) S V1(S)=X
;
F D S IX2=$Q(@IX2) Q:IX2="" Q:$NA(@IX2,NS+SS)'=IXV!$G(DIKKQUIT)
. ;Set iens and DA array for the 2nd index
. S IENS2=$E(IX2,$L(IXV)+1,$L(IX2)-1),L=$L(IENS2,",")
. S DA=$P(IENS2,",",L) F I=1:1:L-1 S DA(I)=$P(IENS2,",",L-I)
. S IENS2=$$IENS(.DA)
. ;
. ;If no subsc >= maxlen, there's a duplicate
. I '$D(ML) D SETK(UIRFIL,IENS2,KEY,DITAR,.DIKKQUIT) S DUPL=1 Q
. ;
. ;Otherwise, compare with actual data
. Q:$D(IENSDONE(IENS2))
. S S=0 F S S=$O(ML(S)) Q:'S X ML(S) I X'=V1(S) Q
. I S S:'$D(NEXTIX1) NEXTIX1=IX2
. E D SETK(UIRFIL,IENS2,KEY,DITAR,.DIKKQUIT) S DUPL=1,IENSDONE(IENS2)=""
;
D:$G(DUPL) SETK(UIRFIL,IENS1,KEY,DITAR,.DIKKQUIT)
Q:'$D(NEXTIX1)
;
S IX1=NEXTIX1,IX2=$Q(@IX1) Q:IX2=""
G:$NA(@IX1,NS+SS)=$NA(@IX2,NS+SS) DLOOP
Q
;
SETN(DIFIL,DIIENS,DIFLD,DITAR,DIKKQUIT) ;
S @DITAR@(DIFIL,DIIENS,DIFLD)=""
;S @DITAR@("N",DIFIL,DIIENS,DIFLD)=""
S:$G(DIKKQUIT)]"" DIKKQUIT=1
Q
;
SETK(DIRFIL,DIIENS,DIKEY,DITAR,DIKKQUIT) ;
S @DITAR@(DIRFIL,DIIENS,"K",DIKEY)=""
;S @DITAR@("K",DIRFIL,DIIENS,DIKEY)=""
S:$G(DIKKQUIT)]"" DIKKQUIT=1
Q
;
IENS(DA) ;Return IENS from DA array
N I,IENS
S IENS=$G(DA)_"," F I=1:1:$O(DA(" "),-1) S IENS=IENS_DA(I)_","
Q IENS
DIKK ;SFISC/MKO-CHECK KEY INTEGRITY ;9:14 AM 23 Feb 1999
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
INTEG(DIFILE,DIREC,DIFLD,DIKKEY,DICTRL,DIKPROC) ;
+1 NEW DA,DIF,DIKERR,DIKFIL,DIKKQUIT,DIMF,DIROOT,DITAR
+2 ;
+3 ;If called as an extrinsic, manipulate DICTRL
+4 SET DIKPROC=$GET(DIKPROC)
+5 IF 'DIKPROC
NEW DICTRL1,DIKKTAR
MERGE DICTRL1=DICTRL
SET DICTRL("TAR")="DIKKTAR"
+6 ;
+7 SET DIF=$EXTRACT("D",$GET(DICTRL)'["d")
+8 IF DIF["D"
IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+9 IF DIF["D"
IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+10 ;
+11 ;Check input params, initialize variables, clean output array
+12 DO INIT^DIKK2
IF $GET(DIKERR)]""
GOTO MOVE
+13 IF 'DIKPROC
IF $GET(DICTRL)'["Q"
SET DICTRL=$GET(DICTRL)_"Q"
+14 ;
+15 ;Load key info into ^TMP("DIKK",$J), and multiple info into DIMF
+16 KILL ^TMP("DIKK",$JOB)
+17 IF $GET(DIKKEY)?."^"
Begin DoDot:1
+18 IF $GET(DIFLD)
Begin DoDot:2
+19 DO LOADFLD^DIKK1(DIKFIL,DIFLD)
End DoDot:2
+20 IF '$TEST
DO LOADALL^DIKK1(DIKFIL,$EXTRACT("s",$GET(DICTRL)["s"),.DIMF)
End DoDot:1
+21 IF '$TEST
DO LOADKEY^DIKK1(DIKKEY)
+22 IF '$ORDER(^TMP("DIKK",$JOB,0))
GOTO EXIT
+23 IF DIKFIL'=DIFILE
DO SBINFO^DIKCU(DIKFIL,.DIMF)
+24 ;
+25 ;Check one or all records in file DIFILE
+26 IF DA
Begin DoDot:1
+27 DO CHECK(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
End DoDot:1
+28 IF '$TEST
DO CHECKALL(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
+29 ;
EXIT ;Cleanup ^TMP and quit
+1 KILL ^TMP("DIKK",$JOB)
+2 ;
MOVE ;Move error messages if necessary
+1 IF DIF["D"
IF $GET(DIERR)
IF $GET(DICTRL("MSG"))]""
DO CALLOUT^DIEFU(DICTRL("MSG"))
+2 IF 'DIKPROC
KILL DICTRL
MERGE DICTRL=DICTRL1
QUIT $DATA(DIKKTAR)=0&($GET(DIKERR)="")
+3 QUIT
+4 ;
CHECK(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Check one record
+1 IF $DATA(^TMP("DIKK",$JOB,"UIR",DIFILE))
DO CHECK^DIKK2(DIFILE,.DA,DITAR,.DIKKQUIT)
IF $GET(DIKKQUIT)
QUIT
+2 IF $DATA(DIMF(DIFILE))
DO CHECKSUB(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
+3 QUIT
+4 ;
CHECKALL(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Check all records
+1 IF $DATA(^TMP("DIKK",$JOB,"UI",DIFILE))
DO UICHK(DIFILE,.DA,DITAR,.DIKKQUIT)
IF $GET(DIKKQUIT)
QUIT
+2 IF '$DATA(^TMP("DIKK",$JOB,DIFILE))
IF '$DATA(DIMF(DIFILE))
QUIT
+3 ;
+4 ;Loop through all records in file, check for null key fields
+5 SET DA=0
FOR
SET DA=$ORDER(@DIROOT@(DA))
IF DA'=+DA
QUIT
Begin DoDot:1
+6 IF $DATA(^TMP("DIKK",$JOB,DIFILE))
DO NULLCHK(DIFILE,.DA,DITAR,.DIKKQUIT)
IF $GET(DIKKQUIT)
QUIT
+7 IF $DATA(DIMF(DIFILE))
DO CHECKSUB(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
End DoDot:1
IF $GET(DIKKQUIT)
QUIT
+8 QUIT
+9 ;
CHECKSUB(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Process all records in subfiles
+1 NEW DIMULTF,DISBFILE,DISBROOT
+2 DO PUSHDA^DIKCU(.DA)
+3 ;
+4 ;Loop through the DIMF array and make recursive call to check all
+5 ;subrecords
+6 SET DIMULTF=0
FOR
SET DIMULTF=$ORDER(DIMF(DIFILE,DIMULTF))
IF 'DIMULTF
QUIT
Begin DoDot:1
+7 SET DISBROOT=$NAME(@DIROOT@(DA(1),DIMF(DIFILE,DIMULTF)))
IF '$DATA(@DISBROOT)
QUIT
+8 SET DISBFILE=DIMF(DIFILE,DIMULTF,0)
+9 DO CHECKALL(DISBFILE,.DA,DISBROOT,.DIMF,DITAR,.DIKKQUIT)
End DoDot:1
IF $GET(DIKKQUIT)
QUIT
+10 ;
+11 DO POPDA^DIKCU(.DA)
+12 QUIT
+13 ;
NULLCHK(KFIL,DA,DITAR,DIKKQUIT) ;Check whether any of the key fields at
+1 ;KFIL file level are null for a given record.
+2 NEW FIL,FLD,IENS,LDIF,X
+3 ;
+4 SET FIL=0
FOR
SET FIL=$ORDER(^TMP("DIKK",$JOB,KFIL,FIL))
IF 'FIL
QUIT
Begin DoDot:1
+5 SET LDIF=+$GET(^TMP("DIKK",$JOB,KFIL,FIL))
+6 SET FLD=0
FOR
SET FLD=$ORDER(^TMP("DIKK",$JOB,KFIL,FIL,FLD))
IF 'FLD
QUIT
Begin DoDot:2
+7 XECUTE ^TMP("DIKK",$JOB,KFIL,FIL,FLD)
IF X]""
QUIT
+8 SET IENS=$$IENS(.DA)
+9 IF LDIF
SET IENS=$PIECE(IENS,",",LDIF+1,999)
+10 DO SETN(FIL,IENS,FLD,DITAR,.DIKKQUIT)
End DoDot:2
IF $GET(DIKKQUIT)
QUIT
End DoDot:1
IF $GET(DIKKQUIT)
QUIT
+11 QUIT
+12 ;
UICHK(FILE,DA,OUT,DIKKQUIT) ;Walk through uniqueness index and check for duplicates
+1 NEW IX0,IX1,IX2,IXV1,IXV2,KEY,KFIL,LDIF,NS,S,SS,UI
+2 ;
+3 SET UI=0
FOR
SET UI=$ORDER(^TMP("DIKK",$JOB,"UI",FILE,UI))
IF 'UI
QUIT
Begin DoDot:1
+4 ;Get info about uniqueness index
+5 SET KEY=$GET(^TMP("DIKK",$JOB,"UI",FILE,UI))
+6 IF $PIECE(KEY,U,2)]""
Begin DoDot:2
+7 SET KFIL=$PIECE(KEY,U,2)
SET LDIF=$PIECE(KEY,U,3)
SET KEY=$PIECE(KEY,U)
+8 SET IX0=^TMP("DIKK",$JOB,"UI",FILE,UI,"UIR")
MERGE SS=^("SS")
End DoDot:2
+9 IF '$TEST
Begin DoDot:2
+10 DO XRINFO^DIKCU2(UI,"",.LDIF,"",.KFIL,.IX0,.SS)
+11 ;
+12 ;Remove elements from the SS array that have no max length.
+13 ;For those that have max length, set SS(S)=data extraction code
+14 SET S=0
FOR
SET S=$ORDER(SS(S))
IF 'S
QUIT
Begin DoDot:3
+15 IF '$PIECE(SS(S),U,3)
KILL SS(S)
QUIT
+16 SET SS(S)=^TMP("DIKK",$JOB,KFIL,$PIECE(SS(S),U),$PIECE(SS(S),U,2))
End DoDot:3
+17 ;
+18 ;Remember info for next time
End DoDot:2
+19 SET KEY=+KEY
+20 SET ^TMP("DIKK",$JOB,"UI",FILE,UI)=KEY_U_KFIL_U_LDIF
SET ^(UI,"UIR")=IX0
+21 MERGE ^TMP("DIKK",$JOB,"UI",FILE,UI,"SS")=SS
+22 ;
+23 ;If necessary, push the DA array
+24 IF LDIF
DO PUSHDA^DIKCU(.DA,LDIF)
+25 ;
+26 ;Walk down the uniqueness index and look for duplicates
+27 SET (IX0,IX1,IX2)=$NAME(@IX0)
SET NS=$QLENGTH(IX0)
+28 FOR
SET IX2=$QUERY(@IX2)
IF IX2=""
QUIT
IF $NAME(@IX2,NS)'=IX0
QUIT
Begin DoDot:2
+29 SET IXV1=$NAME(@IX1,NS+SS)
SET IXV2=$NAME(@IX2,NS+SS)
+30 IF IXV1'=IXV2
SET IX1=IX2
QUIT
+31 DO DUPL(KEY,UI,FILE,KFIL,.DA,IX1,IX2,IXV1,NS,.SS,.DIKKQUIT)
+32 SET (IX1,IX2)=$NAME(@IXV1@("~"))
End DoDot:2
IF $GET(DIKKQUIT)
QUIT
+33 ;
+34 ;Pop the DA array
+35 IF LDIF
DO POPDA^DIKCU(.DA,LDIF)
End DoDot:1
IF $GET(DIKKQUIT)
QUIT
+36 QUIT
+37 ;
DUPL(KEY,UI,UIFIL,UIRFIL,DA,IX1,IX2,IXV,NS,SS,DIKKQUIT) ;Process duplicate
+1 ;indexes
+2 NEW DUPL,IENSDONE,I,IENS1,IENS2,L,ML,NEXTIX1,S,V1,X
+3 ;
+4 ;Set ML(subsc)=SS(subsc) for those subscripts that are >= maxlength
+5 SET S=0
+6 FOR
SET S=$ORDER(SS(S))
IF 'S
QUIT
IF $LENGTH($QSUBSCRIPT(IXV,NS+S))'<$PIECE(SS(S),U,3)
SET ML(S)=SS(S)
+7 ;
DLOOP ;Compare IX1 with IX2 and subsequent indexes
+1 KILL NEXTIX1
+2 ;
+3 ;Set iens and DA array for 1st index
+4 SET IENS1=$EXTRACT(IX1,$LENGTH(IXV)+1,$LENGTH(IX1)-1)
SET L=$LENGTH(IENS1,",")
+5 SET DA=$PIECE(IENS1,",",L)
FOR I=1:1:L-1
SET DA(I)=$PIECE(IENS1,",",L-I)
+6 SET IENS1=$$IENS(.DA)
+7 ;
+8 ;If any subsc >= maxlen, set V1(subsc) = value array for 1st index
+9 IF $DATA(ML)
KILL V1
SET S=0
FOR
SET S=$ORDER(ML(S))
IF 'S
QUIT
XECUTE ML(S)
SET V1(S)=X
+10 ;
+11 FOR
Begin DoDot:1
+12 ;Set iens and DA array for the 2nd index
+13 SET IENS2=$EXTRACT(IX2,$LENGTH(IXV)+1,$LENGTH(IX2)-1)
SET L=$LENGTH(IENS2,",")
+14 SET DA=$PIECE(IENS2,",",L)
FOR I=1:1:L-1
SET DA(I)=$PIECE(IENS2,",",L-I)
+15 SET IENS2=$$IENS(.DA)
+16 ;
+17 ;If no subsc >= maxlen, there's a duplicate
+18 IF '$DATA(ML)
DO SETK(UIRFIL,IENS2,KEY,DITAR,.DIKKQUIT)
SET DUPL=1
QUIT
+19 ;
+20 ;Otherwise, compare with actual data
+21 IF $DATA(IENSDONE(IENS2))
QUIT
+22 SET S=0
FOR
SET S=$ORDER(ML(S))
IF 'S
QUIT
XECUTE ML(S)
IF X'=V1(S)
QUIT
+23 IF S
IF '$DATA(NEXTIX1)
SET NEXTIX1=IX2
+24 IF '$TEST
DO SETK(UIRFIL,IENS2,KEY,DITAR,.DIKKQUIT)
SET DUPL=1
SET IENSDONE(IENS2)=""
End DoDot:1
SET IX2=$QUERY(@IX2)
IF IX2=""
QUIT
IF $NAME(@IX2,NS+SS)'=IXV!$GET(DIKKQUIT)
QUIT
+25 ;
+26 IF $GET(DUPL)
DO SETK(UIRFIL,IENS1,KEY,DITAR,.DIKKQUIT)
+27 IF '$DATA(NEXTIX1)
QUIT
+28 ;
+29 SET IX1=NEXTIX1
SET IX2=$QUERY(@IX1)
IF IX2=""
QUIT
+30 IF $NAME(@IX1,NS+SS)=$NAME(@IX2,NS+SS)
GOTO DLOOP
+31 QUIT
+32 ;
SETN(DIFIL,DIIENS,DIFLD,DITAR,DIKKQUIT) ;
+1 SET @DITAR@(DIFIL,DIIENS,DIFLD)=""
+2 ;S @DITAR@("N",DIFIL,DIIENS,DIFLD)=""
+3 IF $GET(DIKKQUIT)]""
SET DIKKQUIT=1
+4 QUIT
+5 ;
SETK(DIRFIL,DIIENS,DIKEY,DITAR,DIKKQUIT) ;
+1 SET @DITAR@(DIRFIL,DIIENS,"K",DIKEY)=""
+2 ;S @DITAR@("K",DIRFIL,DIIENS,DIKEY)=""
+3 IF $GET(DIKKQUIT)]""
SET DIKKQUIT=1
+4 QUIT
+5 ;
IENS(DA) ;Return IENS from DA array
+1 NEW I,IENS
+2 SET IENS=$GET(DA)_","
FOR I=1:1:$ORDER(DA(" "),-1)
SET IENS=IENS_DA(I)_","
+3 QUIT IENS
