DIEVK1 ;SFISC/MKO-KEY VALIDATION ;06:38 PM 6 Dec 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.
;
BUILD(DIVKFDA,DIVKFLAG) ;Loop thru FDA and load key info
N DIVKEYOK,DIVKFIL,DIVKFLD,DIVKIENS,DIVKQUIT
;
S DIVKEYOK=1,DIVKFIL=0
F S DIVKFIL=$O(@DIVKFDA@(DIVKFIL)) Q:'DIVKFIL D Q:$G(DIVKQUIT)
. Q:'$D(^DD("KEY","F",DIVKFIL))
. D:$G(DIVKFLAG)["K" GETPKEY(DIVKFIL)
. S DIVKIENS=""
. F S DIVKIENS=$O(@DIVKFDA@(DIVKFIL,DIVKIENS)) Q:DIVKIENS="" D Q:$G(DIVKQUIT)
.. I $G(DIVKFLAG)["K",$E(DIVKIENS)="?",$E(DIVKIENS,2)'="+",'$$KFLD(DIVKFIL,DIVKIENS,DIVKFDA) S DIVKEYOK=0 I $G(DIVKFLAG)["Q" S DIVKQUIT=1 Q
.. S DIVKFLD=0
.. F S DIVKFLD=$O(@DIVKFDA@(DIVKFIL,DIVKIENS,DIVKFLD)) Q:'DIVKFLD D BLDFLD(DIVKFIL,DIVKIENS,DIVKFLD)
Q DIVKEYOK
;
BLDFLD(DIVKFIL,DIVKIENS,DIVKFLD) ;Build key/index info on a given field
; ^TMP("DIKK",$J,"L",key) = rfile^ui^priority
; ... ,file,iens) = ""
; ... ,"UIR") = uir
; ... ,"SS",n) = file^field^maxlen
N DIVKEY,DIVKPRI,DIVKRFIL,DIVKSS,DIVKUI,DIVKUIR
;
S DIVKEY=0
F S DIVKEY=$O(^DD("KEY","F",DIVKFIL,DIVKFLD,DIVKEY)) Q:'DIVKEY D
. Q:$D(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS))#2 S ^(DIVKIENS)=""
. Q:$D(^TMP("DIKK",$J,"L",DIVKEY))#2
. ;
. D LOADKEY^DIKK1(DIVKEY)
. S DIVKRFIL=$P($G(^DD("KEY",DIVKEY,0)),U),DIVKUI=$P($G(^(0)),U,4),DIVKPRI=$P($G(^(0)),U,3)
. S ^TMP("DIKK",$J,"L",DIVKEY)=DIVKRFIL_U_DIVKUI_U_DIVKPRI
. Q:'DIVKRFIL!'DIVKUI
. D XRINFO^DIKCU2(DIVKUI,.DIVKUIR,"","","","",.DIVKSS)
. S ^TMP("DIKK",$J,"L",DIVKEY,"UIR")=DIVKUIR
. M ^TMP("DIKK",$J,"L",DIVKEY,"SS")=DIVKSS
Q
;
GETPKEY(KFIL) ;Get fields in primary key for file KFIL
; ^TMP("DIKK",$J,"P",kfile) = key^ui#^uifile^uiname
; ... ,file,field) = seq#
;
N FIL,FLD,I,KEY,SEQ,UI
S KEY=$O(^DD("KEY","AP",KFIL,"P",0)) Q:'KEY
S I=0 F S I=$O(^DD("KEY",KEY,2,I)) Q:'I D
. Q:$D(^DD("KEY",KEY,2,I,0))[0 S FLD=$P(^(0),U),FIL=$P(^(0),U,2),SEQ=$P(^(0),U,3)
. Q:'FLD!'FIL!'SEQ
. S ^TMP("DIKK",$J,"P",KFIL,FIL,FLD)=SEQ
I $D(^TMP("DIKK",$J,"P",KFIL)) D
. S UI=$P(^DD("KEY",KEY,0),U,4)
. S ^TMP("DIKK",$J,"P",KFIL)=KEY_U_UI_U_$P($G(^DD("IX",+UI,0)),U,1,2)
Q
;
KFLD(KFIL,IENS,FDA) ;Check that at least one primary key field is in FDA
N FIL,FLD,KEY,OK,SEQ
S KEY=+$G(^TMP("DIKK",$J,"P",KFIL)) Q:'KEY 1
S OK=0
S FIL=0 F S FIL=$O(^TMP("DIKK",$J,"P",KFIL,FIL)) Q:'FIL D Q:OK
. S FLD=0 F S FLD=$O(^TMP("DIKK",$J,"P",KFIL,FIL,FLD)) Q:'FLD D Q:OK
.. S:"@"'[$G(@FDA@(FIL,IENS,FLD)) OK=1
D:'OK ERR746(KFIL,KEY,IENS)
Q OK
;
FINDCONV(DIVKIENS,DIVKFIEN) ;Replace ?n in DIVKIENS with actual ien's
N I,N,P
F I=1:1:$L(DIVKIENS,",")-1 D
. S P=$P(DIVKIENS,",",I) Q:P'["?"
. S N=$G(@DIVKFIEN@($TR(P,"?+"))) Q:'N
. S $P(DIVKIENS,",",I)=+$G(@DIVKFIEN@($TR(P,"?+")))
Q DIVKIENS
;
ERR740(FILE,KEY,IENS) ;New values are invalid because they create a duplicate
;Key '|1|' for the |2| file.
N P,PEXT
S P(1)=$P(^DD("KEY",KEY,0),U,2)
S P(2)=$$FILENAME^DIALOGZ(FILE) S:P(2)?." " P(2)="#"_FILE ;**CCO/NI FILE NAME
S PEXT("FILE")=FILE,PEXT("KEY")=KEY,PEXT("IENS")=IENS
D BLD^DIALOG(740,.P,.PEXT)
Q
;
ERR742(FILE,FIELD,KEY,IENS) ; The value of field |1| in the |2| file
;cannot be deleted because that field is part of the '|3|' key.
N P,PEXT
S P(1)=$$FLDNM^DIEFU(FILE,FIELD)
S P(2)=$$FILENAME^DIALOGZ(FILE) S:P(2)?." " P(2)="#"_FILE ;**CCO/NI FILE NAME
S P(3)=$P(^DD("KEY",KEY,0),U,2)
S PEXT("FILE")=FILE,PEXT("FIELD")=FIELD,PEXT("IENS")=IENS
D BLD^DIALOG(742,.P,.PEXT)
Q
;
ERR744(FILE,FIELD,KEY,IENS) ;Field |1| is part of Key '|2|', but the
;field has not been assigned a value.
N P,PEXT
S P(1)=$$FLDNM^DIEFU(FILE,FIELD)
S P(2)=$P(^DD("KEY",KEY,0),U,2)
S PEXT("FILE")=FILE,PEXT("FIELD")=FIELD,PEXT("IENS")=IENS
D BLD^DIALOG(744,.P,.PEXT)
Q
;
ERR746(FILE,KEY,IENS) ;At least one field in Primary Key '|1|' must be
;provided in the FDA to look up '|IENS|' in the |2| file.
N P,PEXT
S P(1)=$P(^DD("KEY",KEY,0),U,2)
S P(2)=$$FILENAME^DIALOGZ(FILE) S:P(2)?." " P(2)="#"_FILE ;**CCO/NI FILE NAME
S P("IENS")=IENS
S PEXT("FILE")=FILE,PEXT("KEY")=KEY,PEXT("IENS")=IENS
D BLD^DIALOG(746,.P,.PEXT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIEVK1 4506 printed Sep 23, 2025@20:23:31 Page 2
DIEVK1 ;SFISC/MKO-KEY VALIDATION ;06:38 PM 6 Dec 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 ;
BUILD(DIVKFDA,DIVKFLAG) ;Loop thru FDA and load key info
+1 NEW DIVKEYOK,DIVKFIL,DIVKFLD,DIVKIENS,DIVKQUIT
+2 ;
+3 SET DIVKEYOK=1
SET DIVKFIL=0
+4 FOR
SET DIVKFIL=$ORDER(@DIVKFDA@(DIVKFIL))
if 'DIVKFIL
QUIT
Begin DoDot:1
+5 if '$DATA(^DD("KEY","F",DIVKFIL))
QUIT
+6 if $GET(DIVKFLAG)["K"
DO GETPKEY(DIVKFIL)
+7 SET DIVKIENS=""
+8 FOR
SET DIVKIENS=$ORDER(@DIVKFDA@(DIVKFIL,DIVKIENS))
if DIVKIENS=""
QUIT
Begin DoDot:2
+9 IF $GET(DIVKFLAG)["K"
IF $EXTRACT(DIVKIENS)="?"
IF $EXTRACT(DIVKIENS,2)'="+"
IF '$$KFLD(DIVKFIL,DIVKIENS,DIVKFDA)
SET DIVKEYOK=0
IF $GET(DIVKFLAG)["Q"
SET DIVKQUIT=1
QUIT
+10 SET DIVKFLD=0
+11 FOR
SET DIVKFLD=$ORDER(@DIVKFDA@(DIVKFIL,DIVKIENS,DIVKFLD))
if 'DIVKFLD
QUIT
DO BLDFLD(DIVKFIL,DIVKIENS,DIVKFLD)
End DoDot:2
if $GET(DIVKQUIT)
QUIT
End DoDot:1
if $GET(DIVKQUIT)
QUIT
+12 QUIT DIVKEYOK
+13 ;
BLDFLD(DIVKFIL,DIVKIENS,DIVKFLD) ;Build key/index info on a given field
+1 ; ^TMP("DIKK",$J,"L",key) = rfile^ui^priority
+2 ; ... ,file,iens) = ""
+3 ; ... ,"UIR") = uir
+4 ; ... ,"SS",n) = file^field^maxlen
+5 NEW DIVKEY,DIVKPRI,DIVKRFIL,DIVKSS,DIVKUI,DIVKUIR
+6 ;
+7 SET DIVKEY=0
+8 FOR
SET DIVKEY=$ORDER(^DD("KEY","F",DIVKFIL,DIVKFLD,DIVKEY))
if 'DIVKEY
QUIT
Begin DoDot:1
+9 if $DATA(^TMP("DIKK",$JOB,"L",DIVKEY,DIVKFIL,DIVKIENS))#2
QUIT
SET ^(DIVKIENS)=""
+10 if $DATA(^TMP("DIKK",$JOB,"L",DIVKEY))#2
QUIT
+11 ;
+12 DO LOADKEY^DIKK1(DIVKEY)
+13 SET DIVKRFIL=$PIECE($GET(^DD("KEY",DIVKEY,0)),U)
SET DIVKUI=$PIECE($GET(^(0)),U,4)
SET DIVKPRI=$PIECE($GET(^(0)),U,3)
+14 SET ^TMP("DIKK",$JOB,"L",DIVKEY)=DIVKRFIL_U_DIVKUI_U_DIVKPRI
+15 if 'DIVKRFIL!'DIVKUI
QUIT
+16 DO XRINFO^DIKCU2(DIVKUI,.DIVKUIR,"","","","",.DIVKSS)
+17 SET ^TMP("DIKK",$JOB,"L",DIVKEY,"UIR")=DIVKUIR
+18 MERGE ^TMP("DIKK",$JOB,"L",DIVKEY,"SS")=DIVKSS
End DoDot:1
+19 QUIT
+20 ;
GETPKEY(KFIL) ;Get fields in primary key for file KFIL
+1 ; ^TMP("DIKK",$J,"P",kfile) = key^ui#^uifile^uiname
+2 ; ... ,file,field) = seq#
+3 ;
+4 NEW FIL,FLD,I,KEY,SEQ,UI
+5 SET KEY=$ORDER(^DD("KEY","AP",KFIL,"P",0))
if 'KEY
QUIT
+6 SET I=0
FOR
SET I=$ORDER(^DD("KEY",KEY,2,I))
if 'I
QUIT
Begin DoDot:1
+7 if $DATA(^DD("KEY",KEY,2,I,0))[0
QUIT
SET FLD=$PIECE(^(0),U)
SET FIL=$PIECE(^(0),U,2)
SET SEQ=$PIECE(^(0),U,3)
+8 if 'FLD!'FIL!'SEQ
QUIT
+9 SET ^TMP("DIKK",$JOB,"P",KFIL,FIL,FLD)=SEQ
End DoDot:1
+10 IF $DATA(^TMP("DIKK",$JOB,"P",KFIL))
Begin DoDot:1
+11 SET UI=$PIECE(^DD("KEY",KEY,0),U,4)
+12 SET ^TMP("DIKK",$JOB,"P",KFIL)=KEY_U_UI_U_$PIECE($GET(^DD("IX",+UI,0)),U,1,2)
End DoDot:1
+13 QUIT
+14 ;
KFLD(KFIL,IENS,FDA) ;Check that at least one primary key field is in FDA
+1 NEW FIL,FLD,KEY,OK,SEQ
+2 SET KEY=+$GET(^TMP("DIKK",$JOB,"P",KFIL))
if 'KEY
QUIT 1
+3 SET OK=0
+4 SET FIL=0
FOR
SET FIL=$ORDER(^TMP("DIKK",$JOB,"P",KFIL,FIL))
if 'FIL
QUIT
Begin DoDot:1
+5 SET FLD=0
FOR
SET FLD=$ORDER(^TMP("DIKK",$JOB,"P",KFIL,FIL,FLD))
if 'FLD
QUIT
Begin DoDot:2
+6 if "@"'[$GET(@FDA@(FIL,IENS,FLD))
SET OK=1
End DoDot:2
if OK
QUIT
End DoDot:1
if OK
QUIT
+7 if 'OK
DO ERR746(KFIL,KEY,IENS)
+8 QUIT OK
+9 ;
FINDCONV(DIVKIENS,DIVKFIEN) ;Replace ?n in DIVKIENS with actual ien's
+1 NEW I,N,P
+2 FOR I=1:1:$LENGTH(DIVKIENS,",")-1
Begin DoDot:1
+3 SET P=$PIECE(DIVKIENS,",",I)
if P'["?"
QUIT
+4 SET N=$GET(@DIVKFIEN@($TRANSLATE(P,"?+")))
if 'N
QUIT
+5 SET $PIECE(DIVKIENS,",",I)=+$GET(@DIVKFIEN@($TRANSLATE(P,"?+")))
End DoDot:1
+6 QUIT DIVKIENS
+7 ;
ERR740(FILE,KEY,IENS) ;New values are invalid because they create a duplicate
+1 ;Key '|1|' for the |2| file.
+2 NEW P,PEXT
+3 SET P(1)=$PIECE(^DD("KEY",KEY,0),U,2)
+4 ;**CCO/NI FILE NAME
SET P(2)=$$FILENAME^DIALOGZ(FILE)
if P(2)?." "
SET P(2)="#"_FILE
+5 SET PEXT("FILE")=FILE
SET PEXT("KEY")=KEY
SET PEXT("IENS")=IENS
+6 DO BLD^DIALOG(740,.P,.PEXT)
+7 QUIT
+8 ;
ERR742(FILE,FIELD,KEY,IENS) ; The value of field |1| in the |2| file
+1 ;cannot be deleted because that field is part of the '|3|' key.
+2 NEW P,PEXT
+3 SET P(1)=$$FLDNM^DIEFU(FILE,FIELD)
+4 ;**CCO/NI FILE NAME
SET P(2)=$$FILENAME^DIALOGZ(FILE)
if P(2)?." "
SET P(2)="#"_FILE
+5 SET P(3)=$PIECE(^DD("KEY",KEY,0),U,2)
+6 SET PEXT("FILE")=FILE
SET PEXT("FIELD")=FIELD
SET PEXT("IENS")=IENS
+7 DO BLD^DIALOG(742,.P,.PEXT)
+8 QUIT
+9 ;
ERR744(FILE,FIELD,KEY,IENS) ;Field |1| is part of Key '|2|', but the
+1 ;field has not been assigned a value.
+2 NEW P,PEXT
+3 SET P(1)=$$FLDNM^DIEFU(FILE,FIELD)
+4 SET P(2)=$PIECE(^DD("KEY",KEY,0),U,2)
+5 SET PEXT("FILE")=FILE
SET PEXT("FIELD")=FIELD
SET PEXT("IENS")=IENS
+6 DO BLD^DIALOG(744,.P,.PEXT)
+7 QUIT
+8 ;
ERR746(FILE,KEY,IENS) ;At least one field in Primary Key '|1|' must be
+1 ;provided in the FDA to look up '|IENS|' in the |2| file.
+2 NEW P,PEXT
+3 SET P(1)=$PIECE(^DD("KEY",KEY,0),U,2)
+4 ;**CCO/NI FILE NAME
SET P(2)=$$FILENAME^DIALOGZ(FILE)
if P(2)?." "
SET P(2)="#"_FILE
+5 SET P("IENS")=IENS
+6 SET PEXT("FILE")=FILE
SET PEXT("KEY")=KEY
SET PEXT("IENS")=IENS
+7 DO BLD^DIALOG(746,.P,.PEXT)
+8 QUIT
