Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIEVK

DIEVK.m

Go to the documentation of this file. 
  1. DIEVK ;SFISC/DPC-KEY VALIDATION ;11:50 AM  5 May 1998
  1.  ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1.  ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1.  ;;Licensed under the terms of the Apache License, Version 2.0.
  1.  ;
  1. KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT,DIVKFIEN) ;
  1. KEYVALX ;
  1.  ;Init
  1.  N DIVKEYOK
  1.  I '$D(DIQUIET) N DIQUIET S DIQUIET=1
  1.  I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
  1.  S DIVKEYOK=1
  1.  ;
  1.  ;Check input variables
  1.  S DIVKFLAG=$G(DIVKFLAG) I '$$VERFLG^DIEFU(DIVKFLAG,"KQ") S DIVKEYOK=0 G OUT
  1.  S DIVKFDA=$G(DIVKFDA) I '$$VROOT^DIEFU(DIVKFDA) S DIVKEYOK=0 G OUT
  1.  ;
  1.  ;Load key info, and list of records to check
  1.  K ^TMP("DIKK",$J)
  1.  I '$$BUILD^DIEVK1(DIVKFDA,DIVKFLAG) S DIVKEYOK=0 G:DIVKFLAG["Q" OUT
  1.  I $D(^TMP("DIKK",$J,"L")),'$$CHECK(DIVKFDA,DIVKFLAG,$G(DIVKFIEN)) D
  1.  . S DIVKEYOK=0
  1.  ;
  1. OUT ;Move error messages if necessary and quit
  1.  I $G(DIERR),$G(DIVKOUT)]"" D CALLOUT^DIEFU(DIVKOUT)
  1.  K ^TMP("DIKK",$J)
  1.  Q DIVKEYOK
  1.  ;
  1. CHECK(DIVKFDA,DIVKFLAG,DIVKFIEN) ;Loop thru ^TMP and check key integrity
  1.  N DIVKCIEN,DIVKFIL,DIVKIENS,DIVKEY,DIVKEYOK,DIVKQUIT
  1.  ;
  1.  ;If DIVKFIEN passed in, build list of resolved ?n ien's
  1.  I $G(DIVKFIEN)]"",$D(@DIVKFIEN) D
  1.  . S DIVKEY=0
  1.  . F  S DIVKEY=$O(^TMP("DIKK",$J,"L",DIVKEY)) Q:'DIVKEY  D
  1.  .. S DIVKFIL=$P(^TMP("DIKK",$J,"L",DIVKEY),U)
  1.  .. S DIVKIENS=""
  1.  .. F  S DIVKIENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS)) Q:DIVKIENS=""  D
  1.  ... Q:DIVKIENS'["?"
  1.  ... I $E(DIVKIENS)="?",$G(DIVKFLAG)["K",$P($G(^TMP("DIKK",$J,"L",DIVKEY)),U,3)="P" Q
  1.  ... S DIVKCIEN=$$FINDCONV^DIEVK1(DIVKIENS,DIVKFIEN)
  1.  ... Q:DIVKCIEN?.E1(1"+",1"?").E
  1.  ... S ^TMP("DIKK",$J,"F",DIVKEY,DIVKFIL,DIVKCIEN)=""
  1.  ;
  1.  ;Check integrity
  1.  S DIVKEYOK=1,DIVKEY=0
  1.  F  S DIVKEY=$O(^TMP("DIKK",$J,"L",DIVKEY)) Q:'DIVKEY  D  Q:$G(DIVKQUIT)
  1.  . S DIVKFIL=$P(^TMP("DIKK",$J,"L",DIVKEY),U)
  1.  . S DIVKIENS=""
  1.  . F  S DIVKIENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS)) Q:DIVKIENS=""  D  Q:$G(DIVKQUIT)
  1.  .. I '$$CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,$G(DIVKFIEN)) D
  1.  ... S DIVKEYOK=0 S:DIVKFLAG["Q" DIVKQUIT=1
  1.  Q DIVKEYOK
  1.  ;
  1. CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,DIVKFIEN) ;
  1.  ;Check integrity of 1 record
  1.  N ACTIENS,CONV,DA,DEC,DEL,FIL,FLD,ML,NULL,OIENS,S,SS,UIR,VAL,X
  1.  ;
  1.  ;Don't need to check primary key for Finding and LAYGO/Finding nodes
  1.  ;used for lookup
  1.  I $E(DIVKIENS)="?",$G(DIVKFLAG)["K",$P($G(^TMP("DIKK",$J,"L",DIVKEY)),U,3)="P" Q 1
  1.  ;
  1.  S UIR=$G(^TMP("DIKK",$J,"L",DIVKEY,"UIR")) M SS=^("SS") Q:UIR="" 1
  1.  ;
  1.  ;Set DA array
  1.  D ACTDA(DIVKIENS,$G(DIVKFIEN),.DA,.CONV)
  1.  ;
  1.  ;Set X array and check for nulls
  1.  ;Set VAL array for values exceeding max length
  1.  ;Set DEC array to data extraction code
  1.  K NULL,VAL,X
  1.  S S=0 F  S S=$O(SS(S)) Q:'S  D  Q:$G(DIVKFLAG)["Q"&$G(NULL)!$G(DEL)
  1.  . S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2),ML=$P(SS(S),U,3)
  1.  . S DEC(S)=^TMP("DIKK",$J,DIVKFIL,FIL,FLD)
  1.  . S X=$$VALUE(FIL,DIVKIENS,.DA,FLD,$G(DIVKFDA),DEC(S),$G(CONV))
  1.  . I X="@",FLD=.01 S DEL=1 Q
  1.  . S X(S)=X
  1.  . I ML,$L(X)'<ML S VAL(S)=X
  1.  . ;
  1.  . I X="@" D ERR742^DIEVK1(FIL,FLD,DIVKEY,DIVKIENS) S NULL=1 Q
  1.  . I X="" D ERR744^DIEVK1(FIL,FLD,DIVKEY,DIVKIENS) S NULL=1 Q
  1.  Q:$G(DEL) 1
  1.  Q:$G(NULL) 0
  1.  ;
  1.  S ACTIENS=$S($G(CONV):$$IENS(.DA),1:DIVKIENS)
  1.  S UIR=$NA(@UIR)
  1.  I $D(@UIR),'$$UNIQIX^DIKK2(UIR,ACTIENS,.DA,.VAL,.DEC,DIVKEY_U_DIVKFIL) D ERR740^DIEVK1(DIVKFIL,DIVKEY,DIVKIENS) Q 0
  1.  I '$$COMP(DIVKEY,DIVKFIL,DIVKIENS,$G(DIVKFDA),.X,.SS,.DEC,$G(DIVKFLAG),$G(DIVKFIEN)) Q 0
  1.  Q 1
  1.  ;
  1. COMP(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKX,SS,DEC,DIVKFLAG,DIVKFIEN) ;
  1.  ;Check uniqueness with subsequent records
  1.  ;in ^TMP("DIKK",$J,"L",key,file)
  1.  N CONV,DA,DIVKQUIT,FIL,FLD,IENS,OK,S,UNIQ,X
  1.  ;
  1.  S OK=1,IENS=DIVKIENS
  1.  F  S IENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,IENS)) Q:IENS=""  D  Q:$G(DIVKQUIT)
  1.  . ;
  1.  . ;Set DA array
  1.  . D ACTDA(IENS,$G(DIVKFIEN),.DA,.CONV)
  1.  . ;
  1.  . S (UNIQ,S)=0 F  S S=$O(SS(S)) Q:'S  D  Q:UNIQ
  1.  .. S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2)
  1.  .. S X=$$VALUE(FIL,IENS,.DA,FLD,$G(DIVKFDA),DEC(S),$G(CONV))
  1.  .. I "@"[X!(X'=DIVKX(S)) S UNIQ=1
  1.  . ;
  1.  . I 'UNIQ D
  1.  .. D:OK ERR740^DIEVK1(DIVKFIL,DIVKEY,DIVKIENS)
  1.  .. D ERR740^DIEVK1(DIVKFIL,DIVKEY,IENS)
  1.  .. S OK=0 S:$G(DIVKFLAG)["Q" DIVKQUIT=1
  1.  Q OK
  1.  ;
  1. VALUE(DIVKEYFL,DIVKIENS,DA,DIVKEYFD,DIVKFDA,DIVKDEC,DIVKCONV) ;
  1.  N DIVKVALU,X
  1.  I $G(DIVKFDA)="" X DIVKDEC Q X
  1.  ;
  1.  ;Get value from FDA
  1.  S DIVKVALU=$G(@DIVKFDA@(DIVKEYFL,DIVKIENS,DIVKEYFD),U)
  1.  Q:"@"[DIVKVALU "@"
  1.  Q:DIVKVALU'=U DIVKVALU
  1.  ;
  1.  ;Get value from file
  1.  I DIVKIENS?.E1(1"+",1"?").E,'$G(DIVKCONV) Q ""
  1.  X DIVKDEC
  1.  Q X
  1.  ;
  1. IENS(DA) ;Return IENS from DA array
  1.  N I,IENS
  1.  S IENS=$G(DA)_"," F I=1:1:$O(DA(" "),-1) S IENS=IENS_DA(I)_","
  1.  Q IENS
  1.  ;
  1. DA(IENS,DA) ;
  1.  N I
  1.  K DA S DA=$P(IENS,",") F I=2:1:$L(IENS,",")-1 S DA(I-1)=$P(IENS,",",I)
  1.  Q
  1.  ;
  1. ACTDA(IENS,DIVKFIEN,DA,CONV) ;Set the DA array from the IENS
  1.  ;If ?'s replaced with actual IENs, return CONV=1
  1.  K CONV
  1.  I IENS["?",$G(DIVKFIEN)]"",$D(@DIVKFIEN) D
  1.  . N RIENS
  1.  . S RIENS=$$FINDCONV^DIEVK1(IENS,DIVKFIEN)
  1.  . D DA(RIENS,.DA)
  1.  . I RIENS'["?",RIENS'["+" S CONV=1
  1.  E  D DA(IENS,.DA)
  1.  Q