source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEVK.m@ 1166

DIEVK ;SFISC/DPC-KEY VALIDATION ;11:50 AM  5 May 1998
 ;;22.0;VA FileMan;;Mar 30, 1999
 ;Per VHA Directive 10-93-142, this routine should not be modified.
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