DIEVK ;SFISC/DPC-KEY VALIDATION ;11:50 AM 5 May 1998
;;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.
;
KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT,DIVKFIEN) ;
KEYVALX ;
;Init
N DIVKEYOK
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
S DIVKEYOK=1
;
;Check input variables
S DIVKFLAG=$G(DIVKFLAG) I '$$VERFLG^DIEFU(DIVKFLAG,"KQ") S DIVKEYOK=0 G OUT
S DIVKFDA=$G(DIVKFDA) I '$$VROOT^DIEFU(DIVKFDA) S DIVKEYOK=0 G OUT
;
;Load key info, and list of records to check
K ^TMP("DIKK",$J)
I '$$BUILD^DIEVK1(DIVKFDA,DIVKFLAG) S DIVKEYOK=0 G:DIVKFLAG["Q" OUT
I $D(^TMP("DIKK",$J,"L")),'$$CHECK(DIVKFDA,DIVKFLAG,$G(DIVKFIEN)) D
. S DIVKEYOK=0
;
OUT ;Move error messages if necessary and quit
I $G(DIERR),$G(DIVKOUT)]"" D CALLOUT^DIEFU(DIVKOUT)
K ^TMP("DIKK",$J)
Q DIVKEYOK
;
CHECK(DIVKFDA,DIVKFLAG,DIVKFIEN) ;Loop thru ^TMP and check key integrity
N DIVKCIEN,DIVKFIL,DIVKIENS,DIVKEY,DIVKEYOK,DIVKQUIT
;
;If DIVKFIEN passed in, build list of resolved ?n ien's
I $G(DIVKFIEN)]"",$D(@DIVKFIEN) D
. S DIVKEY=0
. F S DIVKEY=$O(^TMP("DIKK",$J,"L",DIVKEY)) Q:'DIVKEY D
.. S DIVKFIL=$P(^TMP("DIKK",$J,"L",DIVKEY),U)
.. S DIVKIENS=""
.. F S DIVKIENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS)) Q:DIVKIENS="" D
... Q:DIVKIENS'["?"
... I $E(DIVKIENS)="?",$G(DIVKFLAG)["K",$P($G(^TMP("DIKK",$J,"L",DIVKEY)),U,3)="P" Q
... S DIVKCIEN=$$FINDCONV^DIEVK1(DIVKIENS,DIVKFIEN)
... Q:DIVKCIEN?.E1(1"+",1"?").E
... S ^TMP("DIKK",$J,"F",DIVKEY,DIVKFIL,DIVKCIEN)=""
;
;Check integrity
S DIVKEYOK=1,DIVKEY=0
F S DIVKEY=$O(^TMP("DIKK",$J,"L",DIVKEY)) Q:'DIVKEY D Q:$G(DIVKQUIT)
. S DIVKFIL=$P(^TMP("DIKK",$J,"L",DIVKEY),U)
. S DIVKIENS=""
. F S DIVKIENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS)) Q:DIVKIENS="" D Q:$G(DIVKQUIT)
.. I '$$CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,$G(DIVKFIEN)) D
... S DIVKEYOK=0 S:DIVKFLAG["Q" DIVKQUIT=1
Q DIVKEYOK
;
CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,DIVKFIEN) ;
;Check integrity of 1 record
N ACTIENS,CONV,DA,DEC,DEL,FIL,FLD,ML,NULL,OIENS,S,SS,UIR,VAL,X
;
;Don't need to check primary key for Finding and LAYGO/Finding nodes
;used for lookup
I $E(DIVKIENS)="?",$G(DIVKFLAG)["K",$P($G(^TMP("DIKK",$J,"L",DIVKEY)),U,3)="P" Q 1
;
S UIR=$G(^TMP("DIKK",$J,"L",DIVKEY,"UIR")) M SS=^("SS") Q:UIR="" 1
;
;Set DA array
D ACTDA(DIVKIENS,$G(DIVKFIEN),.DA,.CONV)
;
;Set X array and check for nulls
;Set VAL array for values exceeding max length
;Set DEC array to data extraction code
K NULL,VAL,X
S S=0 F S S=$O(SS(S)) Q:'S D Q:$G(DIVKFLAG)["Q"&$G(NULL)!$G(DEL)
. S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2),ML=$P(SS(S),U,3)
. S DEC(S)=^TMP("DIKK",$J,DIVKFIL,FIL,FLD)
. S X=$$VALUE(FIL,DIVKIENS,.DA,FLD,$G(DIVKFDA),DEC(S),$G(CONV))
. I X="@",FLD=.01 S DEL=1 Q
. S X(S)=X
. I ML,$L(X)'<ML S VAL(S)=X
. ;
. I X="@" D ERR742^DIEVK1(FIL,FLD,DIVKEY,DIVKIENS) S NULL=1 Q
. I X="" D ERR744^DIEVK1(FIL,FLD,DIVKEY,DIVKIENS) S NULL=1 Q
Q:$G(DEL) 1
Q:$G(NULL) 0
;
S ACTIENS=$S($G(CONV):$$IENS(.DA),1:DIVKIENS)
S UIR=$NA(@UIR)
I $D(@UIR),'$$UNIQIX^DIKK2(UIR,ACTIENS,.DA,.VAL,.DEC,DIVKEY_U_DIVKFIL) D ERR740^DIEVK1(DIVKFIL,DIVKEY,DIVKIENS) Q 0
I '$$COMP(DIVKEY,DIVKFIL,DIVKIENS,$G(DIVKFDA),.X,.SS,.DEC,$G(DIVKFLAG),$G(DIVKFIEN)) Q 0
Q 1
;
COMP(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKX,SS,DEC,DIVKFLAG,DIVKFIEN) ;
;Check uniqueness with subsequent records
;in ^TMP("DIKK",$J,"L",key,file)
N CONV,DA,DIVKQUIT,FIL,FLD,IENS,OK,S,UNIQ,X
;
S OK=1,IENS=DIVKIENS
F S IENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,IENS)) Q:IENS="" D Q:$G(DIVKQUIT)
. ;
. ;Set DA array
. D ACTDA(IENS,$G(DIVKFIEN),.DA,.CONV)
. ;
. S (UNIQ,S)=0 F S S=$O(SS(S)) Q:'S D Q:UNIQ
.. S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2)
.. S X=$$VALUE(FIL,IENS,.DA,FLD,$G(DIVKFDA),DEC(S),$G(CONV))
.. I "@"[X!(X'=DIVKX(S)) S UNIQ=1
. ;
. I 'UNIQ D
.. D:OK ERR740^DIEVK1(DIVKFIL,DIVKEY,DIVKIENS)
.. D ERR740^DIEVK1(DIVKFIL,DIVKEY,IENS)
.. S OK=0 S:$G(DIVKFLAG)["Q" DIVKQUIT=1
Q OK
;
VALUE(DIVKEYFL,DIVKIENS,DA,DIVKEYFD,DIVKFDA,DIVKDEC,DIVKCONV) ;
N DIVKVALU,X
I $G(DIVKFDA)="" X DIVKDEC Q X
;
;Get value from FDA
S DIVKVALU=$G(@DIVKFDA@(DIVKEYFL,DIVKIENS,DIVKEYFD),U)
Q:"@"[DIVKVALU "@"
Q:DIVKVALU'=U DIVKVALU
;
;Get value from file
I DIVKIENS?.E1(1"+",1"?").E,'$G(DIVKCONV) Q ""
X DIVKDEC
Q X
;
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
;
DA(IENS,DA) ;
N I
K DA S DA=$P(IENS,",") F I=2:1:$L(IENS,",")-1 S DA(I-1)=$P(IENS,",",I)
Q
;
ACTDA(IENS,DIVKFIEN,DA,CONV) ;Set the DA array from the IENS
;If ?'s replaced with actual IENs, return CONV=1
K CONV
I IENS["?",$G(DIVKFIEN)]"",$D(@DIVKFIEN) D
. N RIENS
. S RIENS=$$FINDCONV^DIEVK1(IENS,DIVKFIEN)
. D DA(RIENS,.DA)
. I RIENS'["?",RIENS'["+" S CONV=1
E D DA(IENS,.DA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIEVK 5198 printed Dec 13, 2024@02:47:24 Page 2
DIEVK ;SFISC/DPC-KEY VALIDATION ;11:50 AM 5 May 1998
+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 ;
KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT,DIVKFIEN) ;
KEYVALX ;
+1 ;Init
+2 NEW DIVKEYOK
+3 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+4 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+5 SET DIVKEYOK=1
+6 ;
+7 ;Check input variables
+8 SET DIVKFLAG=$GET(DIVKFLAG)
IF '$$VERFLG^DIEFU(DIVKFLAG,"KQ")
SET DIVKEYOK=0
GOTO OUT
+9 SET DIVKFDA=$GET(DIVKFDA)
IF '$$VROOT^DIEFU(DIVKFDA)
SET DIVKEYOK=0
GOTO OUT
+10 ;
+11 ;Load key info, and list of records to check
+12 KILL ^TMP("DIKK",$JOB)
+13 IF '$$BUILD^DIEVK1(DIVKFDA,DIVKFLAG)
SET DIVKEYOK=0
if DIVKFLAG["Q"
GOTO OUT
+14 IF $DATA(^TMP("DIKK",$JOB,"L"))
IF '$$CHECK(DIVKFDA,DIVKFLAG,$GET(DIVKFIEN))
Begin DoDot:1
+15 SET DIVKEYOK=0
End DoDot:1
+16 ;
OUT ;Move error messages if necessary and quit
+1 IF $GET(DIERR)
IF $GET(DIVKOUT)]""
DO CALLOUT^DIEFU(DIVKOUT)
+2 KILL ^TMP("DIKK",$JOB)
+3 QUIT DIVKEYOK
+4 ;
CHECK(DIVKFDA,DIVKFLAG,DIVKFIEN) ;Loop thru ^TMP and check key integrity
+1 NEW DIVKCIEN,DIVKFIL,DIVKIENS,DIVKEY,DIVKEYOK,DIVKQUIT
+2 ;
+3 ;If DIVKFIEN passed in, build list of resolved ?n ien's
+4 IF $GET(DIVKFIEN)]""
IF $DATA(@DIVKFIEN)
Begin DoDot:1
+5 SET DIVKEY=0
+6 FOR
SET DIVKEY=$ORDER(^TMP("DIKK",$JOB,"L",DIVKEY))
if 'DIVKEY
QUIT
Begin DoDot:2
+7 SET DIVKFIL=$PIECE(^TMP("DIKK",$JOB,"L",DIVKEY),U)
+8 SET DIVKIENS=""
+9 FOR
SET DIVKIENS=$ORDER(^TMP("DIKK",$JOB,"L",DIVKEY,DIVKFIL,DIVKIENS))
if DIVKIENS=""
QUIT
Begin DoDot:3
+10 if DIVKIENS'["?"
QUIT
+11 IF $EXTRACT(DIVKIENS)="?"
IF $GET(DIVKFLAG)["K"
IF $PIECE($GET(^TMP("DIKK",$JOB,"L",DIVKEY)),U,3)="P"
QUIT
+12 SET DIVKCIEN=$$FINDCONV^DIEVK1(DIVKIENS,DIVKFIEN)
+13 if DIVKCIEN?.E1(1"+",1"?").E
QUIT
+14 SET ^TMP("DIKK",$JOB,"F",DIVKEY,DIVKFIL,DIVKCIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
+16 ;Check integrity
+17 SET DIVKEYOK=1
SET DIVKEY=0
+18 FOR
SET DIVKEY=$ORDER(^TMP("DIKK",$JOB,"L",DIVKEY))
if 'DIVKEY
QUIT
Begin DoDot:1
+19 SET DIVKFIL=$PIECE(^TMP("DIKK",$JOB,"L",DIVKEY),U)
+20 SET DIVKIENS=""
+21 FOR
SET DIVKIENS=$ORDER(^TMP("DIKK",$JOB,"L",DIVKEY,DIVKFIL,DIVKIENS))
if DIVKIENS=""
QUIT
Begin DoDot:2
+22 IF '$$CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,$GET(DIVKFIEN))
Begin DoDot:3
+23 SET DIVKEYOK=0
if DIVKFLAG["Q"
SET DIVKQUIT=1
End DoDot:3
End DoDot:2
if $GET(DIVKQUIT)
QUIT
End DoDot:1
if $GET(DIVKQUIT)
QUIT
+24 QUIT DIVKEYOK
+25 ;
CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,DIVKFIEN) ;
+1 ;Check integrity of 1 record
+2 NEW ACTIENS,CONV,DA,DEC,DEL,FIL,FLD,ML,NULL,OIENS,S,SS,UIR,VAL,X
+3 ;
+4 ;Don't need to check primary key for Finding and LAYGO/Finding nodes
+5 ;used for lookup
+6 IF $EXTRACT(DIVKIENS)="?"
IF $GET(DIVKFLAG)["K"
IF $PIECE($GET(^TMP("DIKK",$JOB,"L",DIVKEY)),U,3)="P"
QUIT 1
+7 ;
+8 SET UIR=$GET(^TMP("DIKK",$JOB,"L",DIVKEY,"UIR"))
MERGE SS=^("SS")
if UIR=""
QUIT 1
+9 ;
+10 ;Set DA array
+11 DO ACTDA(DIVKIENS,$GET(DIVKFIEN),.DA,.CONV)
+12 ;
+13 ;Set X array and check for nulls
+14 ;Set VAL array for values exceeding max length
+15 ;Set DEC array to data extraction code
+16 KILL NULL,VAL,X
+17 SET S=0
FOR
SET S=$ORDER(SS(S))
if 'S
QUIT
Begin DoDot:1
+18 SET FIL=$PIECE(SS(S),U)
SET FLD=$PIECE(SS(S),U,2)
SET ML=$PIECE(SS(S),U,3)
+19 SET DEC(S)=^TMP("DIKK",$JOB,DIVKFIL,FIL,FLD)
+20 SET X=$$VALUE(FIL,DIVKIENS,.DA,FLD,$GET(DIVKFDA),DEC(S),$GET(CONV))
+21 IF X="@"
IF FLD=.01
SET DEL=1
QUIT
+22 SET X(S)=X
+23 IF ML
IF $LENGTH(X)'<ML
SET VAL(S)=X
+24 ;
+25 IF X="@"
DO ERR742^DIEVK1(FIL,FLD,DIVKEY,DIVKIENS)
SET NULL=1
QUIT
+26 IF X=""
DO ERR744^DIEVK1(FIL,FLD,DIVKEY,DIVKIENS)
SET NULL=1
QUIT
End DoDot:1
if $GET(DIVKFLAG)["Q"&$GET(NULL)!$GET(DEL)
QUIT
+27 if $GET(DEL)
QUIT 1
+28 if $GET(NULL)
QUIT 0
+29 ;
+30 SET ACTIENS=$SELECT($GET(CONV):$$IENS(.DA),1:DIVKIENS)
+31 SET UIR=$NAME(@UIR)
+32 IF $DATA(@UIR)
IF '$$UNIQIX^DIKK2(UIR,ACTIENS,.DA,.VAL,.DEC,DIVKEY_U_DIVKFIL)
DO ERR740^DIEVK1(DIVKFIL,DIVKEY,DIVKIENS)
QUIT 0
+33 IF '$$COMP(DIVKEY,DIVKFIL,DIVKIENS,$GET(DIVKFDA),.X,.SS,.DEC,$GET(DIVKFLAG),$GET(DIVKFIEN))
QUIT 0
+34 QUIT 1
+35 ;
COMP(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKX,SS,DEC,DIVKFLAG,DIVKFIEN) ;
+1 ;Check uniqueness with subsequent records
+2 ;in ^TMP("DIKK",$J,"L",key,file)
+3 NEW CONV,DA,DIVKQUIT,FIL,FLD,IENS,OK,S,UNIQ,X
+4 ;
+5 SET OK=1
SET IENS=DIVKIENS
+6 FOR
SET IENS=$ORDER(^TMP("DIKK",$JOB,"L",DIVKEY,DIVKFIL,IENS))
if IENS=""
QUIT
Begin DoDot:1
+7 ;
+8 ;Set DA array
+9 DO ACTDA(IENS,$GET(DIVKFIEN),.DA,.CONV)
+10 ;
+11 SET (UNIQ,S)=0
FOR
SET S=$ORDER(SS(S))
if 'S
QUIT
Begin DoDot:2
+12 SET FIL=$PIECE(SS(S),U)
SET FLD=$PIECE(SS(S),U,2)
+13 SET X=$$VALUE(FIL,IENS,.DA,FLD,$GET(DIVKFDA),DEC(S),$GET(CONV))
+14 IF "@"[X!(X'=DIVKX(S))
SET UNIQ=1
End DoDot:2
if UNIQ
QUIT
+15 ;
+16 IF 'UNIQ
Begin DoDot:2
+17 if OK
DO ERR740^DIEVK1(DIVKFIL,DIVKEY,DIVKIENS)
+18 DO ERR740^DIEVK1(DIVKFIL,DIVKEY,IENS)
+19 SET OK=0
if $GET(DIVKFLAG)["Q"
SET DIVKQUIT=1
End DoDot:2
End DoDot:1
if $GET(DIVKQUIT)
QUIT
+20 QUIT OK
+21 ;
VALUE(DIVKEYFL,DIVKIENS,DA,DIVKEYFD,DIVKFDA,DIVKDEC,DIVKCONV) ;
+1 NEW DIVKVALU,X
+2 IF $GET(DIVKFDA)=""
XECUTE DIVKDEC
QUIT X
+3 ;
+4 ;Get value from FDA
+5 SET DIVKVALU=$GET(@DIVKFDA@(DIVKEYFL,DIVKIENS,DIVKEYFD),U)
+6 if "@"[DIVKVALU
QUIT "@"
+7 if DIVKVALU'=U
QUIT DIVKVALU
+8 ;
+9 ;Get value from file
+10 IF DIVKIENS?.E1(1"+",1"?").E
IF '$GET(DIVKCONV)
QUIT ""
+11 XECUTE DIVKDEC
+12 QUIT X
+13 ;
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
+4 ;
DA(IENS,DA) ;
+1 NEW I
+2 KILL DA
SET DA=$PIECE(IENS,",")
FOR I=2:1:$LENGTH(IENS,",")-1
SET DA(I-1)=$PIECE(IENS,",",I)
+3 QUIT
+4 ;
ACTDA(IENS,DIVKFIEN,DA,CONV) ;Set the DA array from the IENS
+1 ;If ?'s replaced with actual IENs, return CONV=1
+2 KILL CONV
+3 IF IENS["?"
IF $GET(DIVKFIEN)]""
IF $DATA(@DIVKFIEN)
Begin DoDot:1
+4 NEW RIENS
+5 SET RIENS=$$FINDCONV^DIEVK1(IENS,DIVKFIEN)
+6 DO DA(RIENS,.DA)
+7 IF RIENS'["?"
IF RIENS'["+"
SET CONV=1
End DoDot:1
+8 IF '$TEST
DO DA(IENS,.DA)
+9 QUIT
