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

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

initial load of WorldVistAEHR
File size: 6.2 KB
Line 
1DIKK ;SFISC/MKO-CHECK KEY INTEGRITY ;9:14 AM 23 Feb 1999
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5INTEG(DIFILE,DIREC,DIFLD,DIKKEY,DICTRL,DIKPROC) ;
6 N DA,DIF,DIKERR,DIKFIL,DIKKQUIT,DIMF,DIROOT,DITAR
7 ;
8 ;If called as an extrinsic, manipulate DICTRL
9 S DIKPROC=$G(DIKPROC)
10 I 'DIKPROC N DICTRL1,DIKKTAR M DICTRL1=DICTRL S DICTRL("TAR")="DIKKTAR"
11 ;
12 S DIF=$E("D",$G(DICTRL)'["d")
13 I DIF["D",'$D(DIQUIET) N DIQUIET S DIQUIET=1
14 I DIF["D",'$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
15 ;
16 ;Check input params, initialize variables, clean output array
17 D INIT^DIKK2 G:$G(DIKERR)]"" MOVE
18 I 'DIKPROC S:$G(DICTRL)'["Q" DICTRL=$G(DICTRL)_"Q"
19 ;
20 ;Load key info into ^TMP("DIKK",$J), and multiple info into DIMF
21 K ^TMP("DIKK",$J)
22 I $G(DIKKEY)?."^" D
23 . I $G(DIFLD) D
24 .. D LOADFLD^DIKK1(DIKFIL,DIFLD)
25 . E D LOADALL^DIKK1(DIKFIL,$E("s",$G(DICTRL)["s"),.DIMF)
26 E D LOADKEY^DIKK1(DIKKEY)
27 G:'$O(^TMP("DIKK",$J,0)) EXIT
28 D:DIKFIL'=DIFILE SBINFO^DIKCU(DIKFIL,.DIMF)
29 ;
30 ;Check one or all records in file DIFILE
31 I DA D
32 . D CHECK(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
33 E D CHECKALL(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
34 ;
35EXIT ;Cleanup ^TMP and quit
36 K ^TMP("DIKK",$J)
37 ;
38MOVE ;Move error messages if necessary
39 I DIF["D",$G(DIERR),$G(DICTRL("MSG"))]"" D CALLOUT^DIEFU(DICTRL("MSG"))
40 I 'DIKPROC K DICTRL M DICTRL=DICTRL1 Q $D(DIKKTAR)=0&($G(DIKERR)="")
41 Q
42 ;
43CHECK(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Check one record
44 I $D(^TMP("DIKK",$J,"UIR",DIFILE)) D CHECK^DIKK2(DIFILE,.DA,DITAR,.DIKKQUIT) Q:$G(DIKKQUIT)
45 D:$D(DIMF(DIFILE)) CHECKSUB(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
46 Q
47 ;
48CHECKALL(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Check all records
49 I $D(^TMP("DIKK",$J,"UI",DIFILE)) D UICHK(DIFILE,.DA,DITAR,.DIKKQUIT) Q:$G(DIKKQUIT)
50 I '$D(^TMP("DIKK",$J,DIFILE)),'$D(DIMF(DIFILE)) Q
51 ;
52 ;Loop through all records in file, check for null key fields
53 S DA=0 F S DA=$O(@DIROOT@(DA)) Q:DA'=+DA D Q:$G(DIKKQUIT)
54 . I $D(^TMP("DIKK",$J,DIFILE)) D NULLCHK(DIFILE,.DA,DITAR,.DIKKQUIT) Q:$G(DIKKQUIT)
55 . D:$D(DIMF(DIFILE)) CHECKSUB(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT)
56 Q
57 ;
58CHECKSUB(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Process all records in subfiles
59 N DIMULTF,DISBFILE,DISBROOT
60 D PUSHDA^DIKCU(.DA)
61 ;
62 ;Loop through the DIMF array and make recursive call to check all
63 ;subrecords
64 S DIMULTF=0 F S DIMULTF=$O(DIMF(DIFILE,DIMULTF)) Q:'DIMULTF D Q:$G(DIKKQUIT)
65 . S DISBROOT=$NA(@DIROOT@(DA(1),DIMF(DIFILE,DIMULTF))) Q:'$D(@DISBROOT)
66 . S DISBFILE=DIMF(DIFILE,DIMULTF,0)
67 . D CHECKALL(DISBFILE,.DA,DISBROOT,.DIMF,DITAR,.DIKKQUIT)
68 ;
69 D POPDA^DIKCU(.DA)
70 Q
71 ;
72NULLCHK(KFIL,DA,DITAR,DIKKQUIT) ;Check whether any of the key fields at
73 ;KFIL file level are null for a given record.
74 N FIL,FLD,IENS,LDIF,X
75 ;
76 S FIL=0 F S FIL=$O(^TMP("DIKK",$J,KFIL,FIL)) Q:'FIL D Q:$G(DIKKQUIT)
77 . S LDIF=+$G(^TMP("DIKK",$J,KFIL,FIL))
78 . S FLD=0 F S FLD=$O(^TMP("DIKK",$J,KFIL,FIL,FLD)) Q:'FLD D Q:$G(DIKKQUIT)
79 .. X ^TMP("DIKK",$J,KFIL,FIL,FLD) Q:X]""
80 .. S IENS=$$IENS(.DA)
81 .. S:LDIF IENS=$P(IENS,",",LDIF+1,999)
82 .. D SETN(FIL,IENS,FLD,DITAR,.DIKKQUIT)
83 Q
84 ;
85UICHK(FILE,DA,OUT,DIKKQUIT) ;Walk through uniqueness index and check for duplicates
86 N IX0,IX1,IX2,IXV1,IXV2,KEY,KFIL,LDIF,NS,S,SS,UI
87 ;
88 S UI=0 F S UI=$O(^TMP("DIKK",$J,"UI",FILE,UI)) Q:'UI D Q:$G(DIKKQUIT)
89 . ;Get info about uniqueness index
90 . S KEY=$G(^TMP("DIKK",$J,"UI",FILE,UI))
91 . I $P(KEY,U,2)]"" D
92 .. S KFIL=$P(KEY,U,2),LDIF=$P(KEY,U,3),KEY=$P(KEY,U)
93 .. S IX0=^TMP("DIKK",$J,"UI",FILE,UI,"UIR") M SS=^("SS")
94 . E D
95 .. D XRINFO^DIKCU2(UI,"",.LDIF,"",.KFIL,.IX0,.SS)
96 .. ;
97 .. ;Remove elements from the SS array that have no max length.
98 .. ;For those that have max length, set SS(S)=data extraction code
99 .. S S=0 F S S=$O(SS(S)) Q:'S D
100 ... I '$P(SS(S),U,3) K SS(S) Q
101 ... S SS(S)=^TMP("DIKK",$J,KFIL,$P(SS(S),U),$P(SS(S),U,2))
102 .. ;
103 .. ;Remember info for next time
104 . S KEY=+KEY
105 . S ^TMP("DIKK",$J,"UI",FILE,UI)=KEY_U_KFIL_U_LDIF,^(UI,"UIR")=IX0
106 . M ^TMP("DIKK",$J,"UI",FILE,UI,"SS")=SS
107 . ;
108 . ;If necessary, push the DA array
109 . D:LDIF PUSHDA^DIKCU(.DA,LDIF)
110 . ;
111 . ;Walk down the uniqueness index and look for duplicates
112 . S (IX0,IX1,IX2)=$NA(@IX0),NS=$QL(IX0)
113 . F S IX2=$Q(@IX2) Q:IX2="" Q:$NA(@IX2,NS)'=IX0 D Q:$G(DIKKQUIT)
114 .. S IXV1=$NA(@IX1,NS+SS),IXV2=$NA(@IX2,NS+SS)
115 .. I IXV1'=IXV2 S IX1=IX2 Q
116 .. D DUPL(KEY,UI,FILE,KFIL,.DA,IX1,IX2,IXV1,NS,.SS,.DIKKQUIT)
117 .. S (IX1,IX2)=$NA(@IXV1@("~"))
118 . ;
119 . ;Pop the DA array
120 . D:LDIF POPDA^DIKCU(.DA,LDIF)
121 Q
122 ;
123DUPL(KEY,UI,UIFIL,UIRFIL,DA,IX1,IX2,IXV,NS,SS,DIKKQUIT) ;Process duplicate
124 ;indexes
125 N DUPL,IENSDONE,I,IENS1,IENS2,L,ML,NEXTIX1,S,V1,X
126 ;
127 ;Set ML(subsc)=SS(subsc) for those subscripts that are >= maxlength
128 S S=0
129 F S S=$O(SS(S)) Q:'S S:$L($QS(IXV,NS+S))'<$P(SS(S),U,3) ML(S)=SS(S)
130 ;
131DLOOP ;Compare IX1 with IX2 and subsequent indexes
132 K NEXTIX1
133 ;
134 ;Set iens and DA array for 1st index
135 S IENS1=$E(IX1,$L(IXV)+1,$L(IX1)-1),L=$L(IENS1,",")
136 S DA=$P(IENS1,",",L) F I=1:1:L-1 S DA(I)=$P(IENS1,",",L-I)
137 S IENS1=$$IENS(.DA)
138 ;
139 ;If any subsc >= maxlen, set V1(subsc) = value array for 1st index
140 I $D(ML) K V1 S S=0 F S S=$O(ML(S)) Q:'S X ML(S) S V1(S)=X
141 ;
142 F D S IX2=$Q(@IX2) Q:IX2="" Q:$NA(@IX2,NS+SS)'=IXV!$G(DIKKQUIT)
143 . ;Set iens and DA array for the 2nd index
144 . S IENS2=$E(IX2,$L(IXV)+1,$L(IX2)-1),L=$L(IENS2,",")
145 . S DA=$P(IENS2,",",L) F I=1:1:L-1 S DA(I)=$P(IENS2,",",L-I)
146 . S IENS2=$$IENS(.DA)
147 . ;
148 . ;If no subsc >= maxlen, there's a duplicate
149 . I '$D(ML) D SETK(UIRFIL,IENS2,KEY,DITAR,.DIKKQUIT) S DUPL=1 Q
150 . ;
151 . ;Otherwise, compare with actual data
152 . Q:$D(IENSDONE(IENS2))
153 . S S=0 F S S=$O(ML(S)) Q:'S X ML(S) I X'=V1(S) Q
154 . I S S:'$D(NEXTIX1) NEXTIX1=IX2
155 . E D SETK(UIRFIL,IENS2,KEY,DITAR,.DIKKQUIT) S DUPL=1,IENSDONE(IENS2)=""
156 ;
157 D:$G(DUPL) SETK(UIRFIL,IENS1,KEY,DITAR,.DIKKQUIT)
158 Q:'$D(NEXTIX1)
159 ;
160 S IX1=NEXTIX1,IX2=$Q(@IX1) Q:IX2=""
161 G:$NA(@IX1,NS+SS)=$NA(@IX2,NS+SS) DLOOP
162 Q
163 ;
164SETN(DIFIL,DIIENS,DIFLD,DITAR,DIKKQUIT) ;
165 S @DITAR@(DIFIL,DIIENS,DIFLD)=""
166 ;S @DITAR@("N",DIFIL,DIIENS,DIFLD)=""
167 S:$G(DIKKQUIT)]"" DIKKQUIT=1
168 Q
169 ;
170SETK(DIRFIL,DIIENS,DIKEY,DITAR,DIKKQUIT) ;
171 S @DITAR@(DIRFIL,DIIENS,"K",DIKEY)=""
172 ;S @DITAR@("K",DIRFIL,DIIENS,DIKEY)=""
173 S:$G(DIKKQUIT)]"" DIKKQUIT=1
174 Q
175 ;
176IENS(DA) ;Return IENS from DA array
177 N I,IENS
178 S IENS=$G(DA)_"," F I=1:1:$O(DA(" "),-1) S IENS=IENS_DA(I)_","
179 Q IENS
Note: See TracBrowser for help on using the repository browser.