DIKK2 ;SFISC/MKO-CHECK INPUT PARAMETERS TO INTEG^DIKK ;2:20 PM 15 Jul 1999
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
;======
; INIT
;======
;Check input parameters to INTEG^DIKK and initialize variables.
;Out:
; DA = DA array
; DIFILE = File #
; DIKFIL = Root (Key) File # (passed in via the W# parameter in DICTRL)
; or DIFILE
; DIROOT = Closed root of file DIFILE
; DITAR = Closed root of ouptut array [default: ^TMP("DIKKTAR",$J)]
; DIKERR = 1 : if there's a problem
; DIKKQUIT = 0 : if DICTRL["Q" (indicates we should quit when the
; first problem is encountered)
;
INIT ;Check and setup
N DILEV,DIIENS
;
;Get and clean output array
S DITAR=$G(DICTRL("TAR")) S:DITAR="" DITAR=$NA(^TMP("DIKKTAR",$J))
K @DITAR
;
;File is required
I $G(DIFILE)="" D:DIF["D" ERR^DIKCU2(202,"","","","FILE") G ERR
;
;Check DIREC and set DA array
I $G(DIREC)'["," M DA=DIREC S DIIENS=$$IENS(.DA)
E S DIIENS=DIREC_$E(",",DIREC'?.E1",") D DA^DILF(DIIENS,.DA)
S:'$G(DA) DA=""
G:'$$VDA^DIKCU1(.DA,DIF) ERR
;
;Set DIFILE and DIROOT
I DIFILE=+$P(DIFILE,"E") D
. S DIROOT=$$FROOTDA^DIKCU(DIFILE,DIF,.DILEV) I DIROOT="" D ERR Q
. I $L(DIIENS,",")-2'=DILEV D Q
.. D:DIF["D" ERR^DIKCU2(205,"",$$IENS(.DA),"",DIFILE) D ERR
. S:DILEV DIROOT=$NA(@DIROOT)
. S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR Q
E D
. S DIROOT=DIFILE
. S:"(,"[$E(DIROOT,$L(DIROOT)) DIROOT=$$CREF^DILF(DIFILE)
. S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR Q
. S DILEV=$$FLEV^DIKCU(DIFILE,DIF) I DILEV="" D ERR Q
. I $L(DIIENS,",")-2'=DILEV D Q
.. D:DIF["D" ERR^DIKCU2(205,"",$$IENS(.DA),"",DIFILE) D ERR
Q:$G(DIKERR)
;
;Check DICTRL parameter
I $G(DICTRL)]"",'$$VFLAG^DIKCU1(DICTRL,"QWds",DIF) G ERR
;
;Set DIKFILE = key (root) file
I $G(DIKKEY) D Q:$G(DIKERR)
. S DIKFIL=$P($G(^DD("KEY",DIKKEY,0)),U)
. I 'DIKFIL D:DIF["D" ERR^DIKCU2(202,"","","","KEY") D ERR
E S DIKFIL=+$P($G(DICTRL),"W",2)
I 'DIKFIL S DIKFIL=DIFILE
E G:'$$VFNUM^DIKCU1(DIKFIL,DIF) ERR
;
K DIKKQUIT S:$G(DICTRL)["Q" DIKKQUIT=0
Q
;
ERR ;Set error flag
S DIKERR=1
Q
;
CHECK(RFIL,DA,DITAR,DIKKQUIT) ;Check key integrity for one record
N FIL,FLD,IENSC,KEY,ML,NULL,S,SS,UI,UIR,VAL,X
S IENSC=$$IENS(.DA)
;
S UI=0 F S UI=$O(^TMP("DIKK",$J,"UIR",RFIL,UI)) Q:'UI S KEY=^(UI) D Q:$G(DIKKQUIT)
. ;Get info about uniqueness index
. D XRINFO^DIKCU2(UI,.UIR,"","","","",.SS)
. ;
. ;Set UIR=root incl X(n); VAL(n)=X(n) if >= maxlen; SS(n)=dec
. K NULL,VAL,X
. S S=0 F S S=$O(SS(S)) Q:'S D Q:$G(DIKKQUIT)
.. S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2),ML=$P(SS(S),U,3)
.. S SS(S)=^TMP("DIKK",$J,RFIL,FIL,FLD)
.. X SS(S) I X="" D SETN^DIKK(FIL,IENSC,FLD,DITAR,.DIKKQUIT) S NULL=1
.. Q:$G(NULL)
.. I ML,$L(X)'<ML S VAL(S)=X
.. S X(S)=X
. Q:$G(NULL)
. ;
. ;Check matching indexes
. S UIR=$NA(@UIR) Q:'$D(@UIR)
. D:'$$UNIQIX(UIR,IENSC,.DA,.VAL,.SS) SETK^DIKK(RFIL,IENSC,KEY,DITAR,.DIKKQUIT)
Q
;
UNIQUE(DIFILE,DIUINDEX,X,DA,DITMP) ;Check whether X values are unique
N DIIENSC,DIMAXL,DIORD,DISS,DIUIR,DIVAL,S
;
I $G(DITMP)="" N DIKKTMP D
. S DITMP="DIKKTMP"
. D LOADXREF^DIKC1("","","",DIUINDEX,"",DITMP)
;
;Get index reference
D XRINFO^DIKCU2(DIUINDEX,.DIUIR,"",.DIMAXL)
S DIUIR=$NA(@DIUIR)
Q:'$D(@DIUIR) 1
;
;There's a matching index
;Set DIVAL(ss#) for those subscripts that may have been truncated
S DIIENSC=$$IENS(.DA)
S DIORD=0
F S DIORD=$O(DIMAXL(DIORD)) Q:'DIORD D:$L(X(DIORD))'<DIMAXL(DIORD)
. S S=+$G(@DITMP@(DIFILE,DIUINDEX,DIORD,"SS")) Q:'S
. S DIVAL(S)=X(DIORD)
. S DISS(S)=$G(@DITMP@(DIFILE,DIUINDEX,DIORD))
Q $$UNIQIX(DIUIR,DIIENSC,.DA,.DIVAL,.DISS)
;
UNIQIX(DIUIR,DIIENSC,DA,DIVAL,DISS,DIEVK) ;
;Loop through the matching indexes; Return 1 if unique
N DIDASV,DIIENS,DINDX,DINS,DION,DIS,DIUNIQ,I,L,X
M DIDASV=DA
S DION="N"
;
S DIUNIQ=1,DINS=$QL(DIUIR),DINDX=DIUIR
F S DINDX=$Q(@DINDX) Q:DINDX="" Q:$NA(@DINDX,DINS)'=DIUIR D Q:'DIUNIQ
. ;Set DA array, quit if this is index for current record
. S DIIENS=$E(DINDX,$L(DIUIR)+1,$L(DINDX)-1),L=$L(DIIENS,",")
. S DA=$P(DIIENS,",",L) F I=1:1:L-1 S DA(I)=$P(DIIENS,",",L-I)
. S DIIENS=$$IENS(.DA) Q:DIIENS=DIIENSC
. ;
. ;If values for this record are being updated via the FDA, don't
. ;bother checking (used by DIEVK)
. I $G(DIEVK) Q:$D(^TMP("DIKK",$J,"L",$P(DIEVK,U),$P(DIEVK,U,2),DIIENS)) Q:$D(^TMP("DIKK",$J,"F",$P(DIEVK,U),$P(DIEVK,U,2),DIIENS))
. ;
. ;If no values in index were truncated, values are not unique.
. I '$D(DIVAL) S DIUNIQ=0 Q
. ;
. ;Set the X array for the indexed record and compare
. S DIS=0 F S DIS=$O(DIVAL(DIS)) Q:'DIS X DISS(DIS) I X'=DIVAL(DIS) Q
. S:'DIS DIUNIQ=0
;
K DA M DA=DIDASV
Q DIUNIQ
;
KEYCHK(DIFIL,DA,DIFLD,DIXREF,DIIENS,DITAR,DINEW) ;Check whether indexes
;in @DIXREF are unique
N DIKEY,DIUINDEX,DIUNIQ,X
I $G(DITAR)]"",$G(DIIENS)="" S DIIENS=$$IENS(.DA)
;
S DIUNIQ=1,DIKEY=0
F S DIKEY=$O(^DD("KEY","F",DIFIL,DIFLD,DIKEY)) Q:'DIKEY D Q:'DIUNIQ
. S DIUINDEX=$P(^DD("KEY",DIKEY,0),U,4)
. Q:'DIUINDEX!'$D(@DIXREF@(DIFIL,DIUINDEX))
. D SETXARR^DIKC(DIFIL,DIUINDEX,DIXREF,"",DINEW)
. S DIUNIQ=$$UNIQUE(DIFIL,DIUINDEX,.X,.DA,DIXREF)
. I 'DIUNIQ,$G(DITAR)]"" D SETK^DIKK(DIFIL,DIIENS,DIKEY,DITAR) S DIUNIQ=1
I $G(DITAR)]"",$D(@DITAR) S DIUNIQ=0
Q DIUNIQ
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKK2 5790 printed Jan 18, 2025@03:50 Page 2
DIKK2 ;SFISC/MKO-CHECK INPUT PARAMETERS TO INTEG^DIKK ;2:20 PM 15 Jul 1999
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 ;======
+8 ; INIT
+9 ;======
+10 ;Check input parameters to INTEG^DIKK and initialize variables.
+11 ;Out:
+12 ; DA = DA array
+13 ; DIFILE = File #
+14 ; DIKFIL = Root (Key) File # (passed in via the W# parameter in DICTRL)
+15 ; or DIFILE
+16 ; DIROOT = Closed root of file DIFILE
+17 ; DITAR = Closed root of ouptut array [default: ^TMP("DIKKTAR",$J)]
+18 ; DIKERR = 1 : if there's a problem
+19 ; DIKKQUIT = 0 : if DICTRL["Q" (indicates we should quit when the
+20 ; first problem is encountered)
+21 ;
INIT ;Check and setup
+1 NEW DILEV,DIIENS
+2 ;
+3 ;Get and clean output array
+4 SET DITAR=$GET(DICTRL("TAR"))
if DITAR=""
SET DITAR=$NAME(^TMP("DIKKTAR",$JOB))
+5 KILL @DITAR
+6 ;
+7 ;File is required
+8 IF $GET(DIFILE)=""
if DIF["D"
DO ERR^DIKCU2(202,"","","","FILE")
GOTO ERR
+9 ;
+10 ;Check DIREC and set DA array
+11 IF $GET(DIREC)'[","
MERGE DA=DIREC
SET DIIENS=$$IENS(.DA)
+12 IF '$TEST
SET DIIENS=DIREC_$EXTRACT(",",DIREC'?.E1",")
DO DA^DILF(DIIENS,.DA)
+13 if '$GET(DA)
SET DA=""
+14 if '$$VDA^DIKCU1(.DA,DIF)
GOTO ERR
+15 ;
+16 ;Set DIFILE and DIROOT
+17 IF DIFILE=+$PIECE(DIFILE,"E")
Begin DoDot:1
+18 SET DIROOT=$$FROOTDA^DIKCU(DIFILE,DIF,.DILEV)
IF DIROOT=""
DO ERR
QUIT
+19 IF $LENGTH(DIIENS,",")-2'=DILEV
Begin DoDot:2
+20 if DIF["D"
DO ERR^DIKCU2(205,"",$$IENS(.DA),"",DIFILE)
DO ERR
End DoDot:2
QUIT
+21 if DILEV
SET DIROOT=$NAME(@DIROOT)
+22 SET DIFILE=$$FNUM^DIKCU(DIROOT,DIF)
IF DIFILE=""
DO ERR
QUIT
End DoDot:1
+23 IF '$TEST
Begin DoDot:1
+24 SET DIROOT=DIFILE
+25 if "(,"[$EXTRACT(DIROOT,$LENGTH(DIROOT))
SET DIROOT=$$CREF^DILF(DIFILE)
+26 SET DIFILE=$$FNUM^DIKCU(DIROOT,DIF)
IF DIFILE=""
DO ERR
QUIT
+27 SET DILEV=$$FLEV^DIKCU(DIFILE,DIF)
IF DILEV=""
DO ERR
QUIT
+28 IF $LENGTH(DIIENS,",")-2'=DILEV
Begin DoDot:2
+29 if DIF["D"
DO ERR^DIKCU2(205,"",$$IENS(.DA),"",DIFILE)
DO ERR
End DoDot:2
QUIT
End DoDot:1
+30 if $GET(DIKERR)
QUIT
+31 ;
+32 ;Check DICTRL parameter
+33 IF $GET(DICTRL)]""
IF '$$VFLAG^DIKCU1(DICTRL,"QWds",DIF)
GOTO ERR
+34 ;
+35 ;Set DIKFILE = key (root) file
+36 IF $GET(DIKKEY)
Begin DoDot:1
+37 SET DIKFIL=$PIECE($GET(^DD("KEY",DIKKEY,0)),U)
+38 IF 'DIKFIL
if DIF["D"
DO ERR^DIKCU2(202,"","","","KEY")
DO ERR
End DoDot:1
if $GET(DIKERR)
QUIT
+39 IF '$TEST
SET DIKFIL=+$PIECE($GET(DICTRL),"W",2)
+40 IF 'DIKFIL
SET DIKFIL=DIFILE
+41 IF '$TEST
if '$$VFNUM^DIKCU1(DIKFIL,DIF)
GOTO ERR
+42 ;
+43 KILL DIKKQUIT
if $GET(DICTRL)["Q"
SET DIKKQUIT=0
+44 QUIT
+45 ;
ERR ;Set error flag
+1 SET DIKERR=1
+2 QUIT
+3 ;
CHECK(RFIL,DA,DITAR,DIKKQUIT) ;Check key integrity for one record
+1 NEW FIL,FLD,IENSC,KEY,ML,NULL,S,SS,UI,UIR,VAL,X
+2 SET IENSC=$$IENS(.DA)
+3 ;
+4 SET UI=0
FOR
SET UI=$ORDER(^TMP("DIKK",$JOB,"UIR",RFIL,UI))
if 'UI
QUIT
SET KEY=^(UI)
Begin DoDot:1
+5 ;Get info about uniqueness index
+6 DO XRINFO^DIKCU2(UI,.UIR,"","","","",.SS)
+7 ;
+8 ;Set UIR=root incl X(n); VAL(n)=X(n) if >= maxlen; SS(n)=dec
+9 KILL NULL,VAL,X
+10 SET S=0
FOR
SET S=$ORDER(SS(S))
if 'S
QUIT
Begin DoDot:2
+11 SET FIL=$PIECE(SS(S),U)
SET FLD=$PIECE(SS(S),U,2)
SET ML=$PIECE(SS(S),U,3)
+12 SET SS(S)=^TMP("DIKK",$JOB,RFIL,FIL,FLD)
+13 XECUTE SS(S)
IF X=""
DO SETN^DIKK(FIL,IENSC,FLD,DITAR,.DIKKQUIT)
SET NULL=1
+14 if $GET(NULL)
QUIT
+15 IF ML
IF $LENGTH(X)'<ML
SET VAL(S)=X
+16 SET X(S)=X
End DoDot:2
if $GET(DIKKQUIT)
QUIT
+17 if $GET(NULL)
QUIT
+18 ;
+19 ;Check matching indexes
+20 SET UIR=$NAME(@UIR)
if '$DATA(@UIR)
QUIT
+21 if '$$UNIQIX(UIR,IENSC,.DA,.VAL,.SS)
DO SETK^DIKK(RFIL,IENSC,KEY,DITAR,.DIKKQUIT)
End DoDot:1
if $GET(DIKKQUIT)
QUIT
+22 QUIT
+23 ;
UNIQUE(DIFILE,DIUINDEX,X,DA,DITMP) ;Check whether X values are unique
+1 NEW DIIENSC,DIMAXL,DIORD,DISS,DIUIR,DIVAL,S
+2 ;
+3 IF $GET(DITMP)=""
NEW DIKKTMP
Begin DoDot:1
+4 SET DITMP="DIKKTMP"
+5 DO LOADXREF^DIKC1("","","",DIUINDEX,"",DITMP)
End DoDot:1
+6 ;
+7 ;Get index reference
+8 DO XRINFO^DIKCU2(DIUINDEX,.DIUIR,"",.DIMAXL)
+9 SET DIUIR=$NAME(@DIUIR)
+10 if '$DATA(@DIUIR)
QUIT 1
+11 ;
+12 ;There's a matching index
+13 ;Set DIVAL(ss#) for those subscripts that may have been truncated
+14 SET DIIENSC=$$IENS(.DA)
+15 SET DIORD=0
+16 FOR
SET DIORD=$ORDER(DIMAXL(DIORD))
if 'DIORD
QUIT
if $LENGTH(X(DIORD))'<DIMAXL(DIORD)
Begin DoDot:1
+17 SET S=+$GET(@DITMP@(DIFILE,DIUINDEX,DIORD,"SS"))
if 'S
QUIT
+18 SET DIVAL(S)=X(DIORD)
+19 SET DISS(S)=$GET(@DITMP@(DIFILE,DIUINDEX,DIORD))
End DoDot:1
+20 QUIT $$UNIQIX(DIUIR,DIIENSC,.DA,.DIVAL,.DISS)
+21 ;
UNIQIX(DIUIR,DIIENSC,DA,DIVAL,DISS,DIEVK) ;
+1 ;Loop through the matching indexes; Return 1 if unique
+2 NEW DIDASV,DIIENS,DINDX,DINS,DION,DIS,DIUNIQ,I,L,X
+3 MERGE DIDASV=DA
+4 SET DION="N"
+5 ;
+6 SET DIUNIQ=1
SET DINS=$QLENGTH(DIUIR)
SET DINDX=DIUIR
+7 FOR
SET DINDX=$QUERY(@DINDX)
if DINDX=""
QUIT
if $NAME(@DINDX,DINS)'=DIUIR
QUIT
Begin DoDot:1
+8 ;Set DA array, quit if this is index for current record
+9 SET DIIENS=$EXTRACT(DINDX,$LENGTH(DIUIR)+1,$LENGTH(DINDX)-1)
SET L=$LENGTH(DIIENS,",")
+10 SET DA=$PIECE(DIIENS,",",L)
FOR I=1:1:L-1
SET DA(I)=$PIECE(DIIENS,",",L-I)
+11 SET DIIENS=$$IENS(.DA)
if DIIENS=DIIENSC
QUIT
+12 ;
+13 ;If values for this record are being updated via the FDA, don't
+14 ;bother checking (used by DIEVK)
+15 IF $GET(DIEVK)
if $DATA(^TMP("DIKK",$JOB,"L",$PIECE(DIEVK,U),$PIECE(DIEVK,U,2),DIIENS))
QUIT
if $DATA(^TMP("DIKK",$JOB,"F",$PIECE(DIEVK,U),$PIECE(DIEVK,U,2),DIIENS))
QUIT
+16 ;
+17 ;If no values in index were truncated, values are not unique.
+18 IF '$DATA(DIVAL)
SET DIUNIQ=0
QUIT
+19 ;
+20 ;Set the X array for the indexed record and compare
+21 SET DIS=0
FOR
SET DIS=$ORDER(DIVAL(DIS))
if 'DIS
QUIT
XECUTE DISS(DIS)
IF X'=DIVAL(DIS)
QUIT
+22 if 'DIS
SET DIUNIQ=0
End DoDot:1
if 'DIUNIQ
QUIT
+23 ;
+24 KILL DA
MERGE DA=DIDASV
+25 QUIT DIUNIQ
+26 ;
KEYCHK(DIFIL,DA,DIFLD,DIXREF,DIIENS,DITAR,DINEW) ;Check whether indexes
+1 ;in @DIXREF are unique
+2 NEW DIKEY,DIUINDEX,DIUNIQ,X
+3 IF $GET(DITAR)]""
IF $GET(DIIENS)=""
SET DIIENS=$$IENS(.DA)
+4 ;
+5 SET DIUNIQ=1
SET DIKEY=0
+6 FOR
SET DIKEY=$ORDER(^DD("KEY","F",DIFIL,DIFLD,DIKEY))
if 'DIKEY
QUIT
Begin DoDot:1
+7 SET DIUINDEX=$PIECE(^DD("KEY",DIKEY,0),U,4)
+8 if 'DIUINDEX!'$DATA(@DIXREF@(DIFIL,DIUINDEX))
QUIT
+9 DO SETXARR^DIKC(DIFIL,DIUINDEX,DIXREF,"",DINEW)
+10 SET DIUNIQ=$$UNIQUE(DIFIL,DIUINDEX,.X,.DA,DIXREF)
+11 IF 'DIUNIQ
IF $GET(DITAR)]""
DO SETK^DIKK(DIFIL,DIIENS,DIKEY,DITAR)
SET DIUNIQ=1
End DoDot:1
if 'DIUNIQ
QUIT
+12 IF $GET(DITAR)]""
IF $DATA(@DITAR)
SET DIUNIQ=0
+13 QUIT DIUNIQ
+14 ;
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
