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

Last change on this file since 808 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1DIEVK ;SFISC/DPC-KEY VALIDATION ;11:50 AM 5 May 1998
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT,DIVKFIEN) ;
5KEYVALX ;
6 ;Init
7 N DIVKEYOK
8 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
9 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
10 S DIVKEYOK=1
11 ;
12 ;Check input variables
13 S DIVKFLAG=$G(DIVKFLAG) I '$$VERFLG^DIEFU(DIVKFLAG,"KQ") S DIVKEYOK=0 G OUT
14 S DIVKFDA=$G(DIVKFDA) I '$$VROOT^DIEFU(DIVKFDA) S DIVKEYOK=0 G OUT
15 ;
16 ;Load key info, and list of records to check
17 K ^TMP("DIKK",$J)
18 I '$$BUILD^DIEVK1(DIVKFDA,DIVKFLAG) S DIVKEYOK=0 G:DIVKFLAG["Q" OUT
19 I $D(^TMP("DIKK",$J,"L")),'$$CHECK(DIVKFDA,DIVKFLAG,$G(DIVKFIEN)) D
20 . S DIVKEYOK=0
21 ;
22OUT ;Move error messages if necessary and quit
23 I $G(DIERR),$G(DIVKOUT)]"" D CALLOUT^DIEFU(DIVKOUT)
24 K ^TMP("DIKK",$J)
25 Q DIVKEYOK
26 ;
27CHECK(DIVKFDA,DIVKFLAG,DIVKFIEN) ;Loop thru ^TMP and check key integrity
28 N DIVKCIEN,DIVKFIL,DIVKIENS,DIVKEY,DIVKEYOK,DIVKQUIT
29 ;
30 ;If DIVKFIEN passed in, build list of resolved ?n ien's
31 I $G(DIVKFIEN)]"",$D(@DIVKFIEN) D
32 . S DIVKEY=0
33 . F S DIVKEY=$O(^TMP("DIKK",$J,"L",DIVKEY)) Q:'DIVKEY D
34 .. S DIVKFIL=$P(^TMP("DIKK",$J,"L",DIVKEY),U)
35 .. S DIVKIENS=""
36 .. F S DIVKIENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS)) Q:DIVKIENS="" D
37 ... Q:DIVKIENS'["?"
38 ... I $E(DIVKIENS)="?",$G(DIVKFLAG)["K",$P($G(^TMP("DIKK",$J,"L",DIVKEY)),U,3)="P" Q
39 ... S DIVKCIEN=$$FINDCONV^DIEVK1(DIVKIENS,DIVKFIEN)
40 ... Q:DIVKCIEN?.E1(1"+",1"?").E
41 ... S ^TMP("DIKK",$J,"F",DIVKEY,DIVKFIL,DIVKCIEN)=""
42 ;
43 ;Check integrity
44 S DIVKEYOK=1,DIVKEY=0
45 F S DIVKEY=$O(^TMP("DIKK",$J,"L",DIVKEY)) Q:'DIVKEY D Q:$G(DIVKQUIT)
46 . S DIVKFIL=$P(^TMP("DIKK",$J,"L",DIVKEY),U)
47 . S DIVKIENS=""
48 . F S DIVKIENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS)) Q:DIVKIENS="" D Q:$G(DIVKQUIT)
49 .. I '$$CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,$G(DIVKFIEN)) D
50 ... S DIVKEYOK=0 S:DIVKFLAG["Q" DIVKQUIT=1
51 Q DIVKEYOK
52 ;
53CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,DIVKFIEN) ;
54 ;Check integrity of 1 record
55 N ACTIENS,CONV,DA,DEC,DEL,FIL,FLD,ML,NULL,OIENS,S,SS,UIR,VAL,X
56 ;
57 ;Don't need to check primary key for Finding and LAYGO/Finding nodes
58 ;used for lookup
59 I $E(DIVKIENS)="?",$G(DIVKFLAG)["K",$P($G(^TMP("DIKK",$J,"L",DIVKEY)),U,3)="P" Q 1
60 ;
61 S UIR=$G(^TMP("DIKK",$J,"L",DIVKEY,"UIR")) M SS=^("SS") Q:UIR="" 1
62 ;
63 ;Set DA array
64 D ACTDA(DIVKIENS,$G(DIVKFIEN),.DA,.CONV)
65 ;
66 ;Set X array and check for nulls
67 ;Set VAL array for values exceeding max length
68 ;Set DEC array to data extraction code
69 K NULL,VAL,X
70 S S=0 F S S=$O(SS(S)) Q:'S D Q:$G(DIVKFLAG)["Q"&$G(NULL)!$G(DEL)
71 . S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2),ML=$P(SS(S),U,3)
72 . S DEC(S)=^TMP("DIKK",$J,DIVKFIL,FIL,FLD)
73 . S X=$$VALUE(FIL,DIVKIENS,.DA,FLD,$G(DIVKFDA),DEC(S),$G(CONV))
74 . I X="@",FLD=.01 S DEL=1 Q
75 . S X(S)=X
76 . I ML,$L(X)'<ML S VAL(S)=X
77 . ;
78 . I X="@" D ERR742^DIEVK1(FIL,FLD,DIVKEY,DIVKIENS) S NULL=1 Q
79 . I X="" D ERR744^DIEVK1(FIL,FLD,DIVKEY,DIVKIENS) S NULL=1 Q
80 Q:$G(DEL) 1
81 Q:$G(NULL) 0
82 ;
83 S ACTIENS=$S($G(CONV):$$IENS(.DA),1:DIVKIENS)
84 S UIR=$NA(@UIR)
85 I $D(@UIR),'$$UNIQIX^DIKK2(UIR,ACTIENS,.DA,.VAL,.DEC,DIVKEY_U_DIVKFIL) D ERR740^DIEVK1(DIVKFIL,DIVKEY,DIVKIENS) Q 0
86 I '$$COMP(DIVKEY,DIVKFIL,DIVKIENS,$G(DIVKFDA),.X,.SS,.DEC,$G(DIVKFLAG),$G(DIVKFIEN)) Q 0
87 Q 1
88 ;
89COMP(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKX,SS,DEC,DIVKFLAG,DIVKFIEN) ;
90 ;Check uniqueness with subsequent records
91 ;in ^TMP("DIKK",$J,"L",key,file)
92 N CONV,DA,DIVKQUIT,FIL,FLD,IENS,OK,S,UNIQ,X
93 ;
94 S OK=1,IENS=DIVKIENS
95 F S IENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,IENS)) Q:IENS="" D Q:$G(DIVKQUIT)
96 . ;
97 . ;Set DA array
98 . D ACTDA(IENS,$G(DIVKFIEN),.DA,.CONV)
99 . ;
100 . S (UNIQ,S)=0 F S S=$O(SS(S)) Q:'S D Q:UNIQ
101 .. S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2)
102 .. S X=$$VALUE(FIL,IENS,.DA,FLD,$G(DIVKFDA),DEC(S),$G(CONV))
103 .. I "@"[X!(X'=DIVKX(S)) S UNIQ=1
104 . ;
105 . I 'UNIQ D
106 .. D:OK ERR740^DIEVK1(DIVKFIL,DIVKEY,DIVKIENS)
107 .. D ERR740^DIEVK1(DIVKFIL,DIVKEY,IENS)
108 .. S OK=0 S:$G(DIVKFLAG)["Q" DIVKQUIT=1
109 Q OK
110 ;
111VALUE(DIVKEYFL,DIVKIENS,DA,DIVKEYFD,DIVKFDA,DIVKDEC,DIVKCONV) ;
112 N DIVKVALU,X
113 I $G(DIVKFDA)="" X DIVKDEC Q X
114 ;
115 ;Get value from FDA
116 S DIVKVALU=$G(@DIVKFDA@(DIVKEYFL,DIVKIENS,DIVKEYFD),U)
117 Q:"@"[DIVKVALU "@"
118 Q:DIVKVALU'=U DIVKVALU
119 ;
120 ;Get value from file
121 I DIVKIENS?.E1(1"+",1"?").E,'$G(DIVKCONV) Q ""
122 X DIVKDEC
123 Q X
124 ;
125IENS(DA) ;Return IENS from DA array
126 N I,IENS
127 S IENS=$G(DA)_"," F I=1:1:$O(DA(" "),-1) S IENS=IENS_DA(I)_","
128 Q IENS
129 ;
130DA(IENS,DA) ;
131 N I
132 K DA S DA=$P(IENS,",") F I=2:1:$L(IENS,",")-1 S DA(I-1)=$P(IENS,",",I)
133 Q
134 ;
135ACTDA(IENS,DIVKFIEN,DA,CONV) ;Set the DA array from the IENS
136 ;If ?'s replaced with actual IENs, return CONV=1
137 K CONV
138 I IENS["?",$G(DIVKFIEN)]"",$D(@DIVKFIEN) D
139 . N RIENS
140 . S RIENS=$$FINDCONV^DIEVK1(IENS,DIVKFIEN)
141 . D DA(RIENS,.DA)
142 . I RIENS'["?",RIENS'["+" S CONV=1
143 E D DA(IENS,.DA)
144 Q
Note: See TracBrowser for help on using the repository browser.