source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIKK2.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: 5.3 KB
Line 
1DIKK2 ;SFISC/MKO-CHECK INPUT PARAMETERS TO INTEG^DIKK ;2:20 PM 15 Jul 1999
2 ;;22.0;VA FileMan;**11**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;======
5 ; INIT
6 ;======
7 ;Check input parameters to INTEG^DIKK and initialize variables.
8 ;Out:
9 ; DA = DA array
10 ; DIFILE = File #
11 ; DIKFIL = Root (Key) File # (passed in via the W# parameter in DICTRL)
12 ; or DIFILE
13 ; DIROOT = Closed root of file DIFILE
14 ; DITAR = Closed root of ouptut array [default: ^TMP("DIKKTAR",$J)]
15 ; DIKERR = 1 : if there's a problem
16 ; DIKKQUIT = 0 : if DICTRL["Q" (indicates we should quit when the
17 ; first problem is encountered)
18 ;
19INIT ;Check and setup
20 N DILEV,DIIENS
21 ;
22 ;Get and clean output array
23 S DITAR=$G(DICTRL("TAR")) S:DITAR="" DITAR=$NA(^TMP("DIKKTAR",$J))
24 K @DITAR
25 ;
26 ;File is required
27 I $G(DIFILE)="" D:DIF["D" ERR^DIKCU2(202,"","","","FILE") G ERR
28 ;
29 ;Check DIREC and set DA array
30 I $G(DIREC)'["," M DA=DIREC S DIIENS=$$IENS(.DA)
31 E S DIIENS=DIREC_$E(",",DIREC'?.E1",") D DA^DILF(DIIENS,.DA)
32 S:'$G(DA) DA=""
33 G:'$$VDA^DIKCU1(.DA,DIF) ERR
34 ;
35 ;Set DIFILE and DIROOT
36 I DIFILE=+$P(DIFILE,"E") D
37 . S DIROOT=$$FROOTDA^DIKCU(DIFILE,DIF,.DILEV) I DIROOT="" D ERR Q
38 . I $L(DIIENS,",")-2'=DILEV D Q
39 .. D:DIF["D" ERR^DIKCU2(205,"",$$IENS(.DA),"",DIFILE) D ERR
40 . S:DILEV DIROOT=$NA(@DIROOT)
41 . S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR Q
42 E D
43 . S DIROOT=DIFILE
44 . S:"(,"[$E(DIROOT,$L(DIROOT)) DIROOT=$$CREF^DILF(DIFILE)
45 . S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR Q
46 . S DILEV=$$FLEV^DIKCU(DIFILE,DIF) I DILEV="" D ERR Q
47 . I $L(DIIENS,",")-2'=DILEV D Q
48 .. D:DIF["D" ERR^DIKCU2(205,"",$$IENS(.DA),"",DIFILE) D ERR
49 Q:$G(DIKERR)
50 ;
51 ;Check DICTRL parameter
52 I $G(DICTRL)]"",'$$VFLAG^DIKCU1(DICTRL,"QWds",DIF) G ERR
53 ;
54 ;Set DIKFILE = key (root) file
55 I $G(DIKKEY) D Q:$G(DIKERR)
56 . S DIKFIL=$P($G(^DD("KEY",DIKKEY,0)),U)
57 . I 'DIKFIL D:DIF["D" ERR^DIKCU2(202,"","","","KEY") D ERR
58 E S DIKFIL=+$P($G(DICTRL),"W",2)
59 I 'DIKFIL S DIKFIL=DIFILE
60 E G:'$$VFNUM^DIKCU1(DIKFIL,DIF) ERR
61 ;
62 K DIKKQUIT S:$G(DICTRL)["Q" DIKKQUIT=0
63 Q
64 ;
65ERR ;Set error flag
66 S DIKERR=1
67 Q
68 ;
69CHECK(RFIL,DA,DITAR,DIKKQUIT) ;Check key integrity for one record
70 N FIL,FLD,IENSC,KEY,ML,NULL,S,SS,UI,UIR,VAL,X
71 S IENSC=$$IENS(.DA)
72 ;
73 S UI=0 F S UI=$O(^TMP("DIKK",$J,"UIR",RFIL,UI)) Q:'UI S KEY=^(UI) D Q:$G(DIKKQUIT)
74 . ;Get info about uniqueness index
75 . D XRINFO^DIKCU2(UI,.UIR,"","","","",.SS)
76 . ;
77 . ;Set UIR=root incl X(n); VAL(n)=X(n) if >= maxlen; SS(n)=dec
78 . K NULL,VAL,X
79 . S S=0 F S S=$O(SS(S)) Q:'S D Q:$G(DIKKQUIT)
80 .. S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2),ML=$P(SS(S),U,3)
81 .. S SS(S)=^TMP("DIKK",$J,RFIL,FIL,FLD)
82 .. X SS(S) I X="" D SETN^DIKK(FIL,IENSC,FLD,DITAR,.DIKKQUIT) S NULL=1
83 .. Q:$G(NULL)
84 .. I ML,$L(X)'<ML S VAL(S)=X
85 .. S X(S)=X
86 . Q:$G(NULL)
87 . ;
88 . ;Check matching indexes
89 . S UIR=$NA(@UIR) Q:'$D(@UIR)
90 . D:'$$UNIQIX(UIR,IENSC,.DA,.VAL,.SS) SETK^DIKK(RFIL,IENSC,KEY,DITAR,.DIKKQUIT)
91 Q
92 ;
93UNIQUE(DIFILE,DIUINDEX,X,DA,DITMP) ;Check whether X values are unique
94 N DIIENSC,DIMAXL,DIORD,DISS,DIUIR,DIVAL,S
95 ;
96 I $G(DITMP)="" N DIKKTMP D
97 . S DITMP="DIKKTMP"
98 . D LOADXREF^DIKC1("","","",DIUINDEX,"",DITMP)
99 ;
100 ;Get index reference
101 D XRINFO^DIKCU2(DIUINDEX,.DIUIR,"",.DIMAXL)
102 S DIUIR=$NA(@DIUIR)
103 Q:'$D(@DIUIR) 1
104 ;
105 ;There's a matching index
106 ;Set DIVAL(ss#) for those subscripts that may have been truncated
107 S DIIENSC=$$IENS(.DA)
108 S DIORD=0
109 F S DIORD=$O(DIMAXL(DIORD)) Q:'DIORD D:$L(X(DIORD))'<DIMAXL(DIORD)
110 . S S=+$G(@DITMP@(DIFILE,DIUINDEX,DIORD,"SS")) Q:'S
111 . S DIVAL(S)=X(DIORD)
112 . S DISS(S)=$G(@DITMP@(DIFILE,DIUINDEX,DIORD))
113 Q $$UNIQIX(DIUIR,DIIENSC,.DA,.DIVAL,.DISS)
114 ;
115UNIQIX(DIUIR,DIIENSC,DA,DIVAL,DISS,DIEVK) ;
116 ;Loop through the matching indexes; Return 1 if unique
117 N DIDASV,DIIENS,DINDX,DINS,DION,DIS,DIUNIQ,I,L,X
118 M DIDASV=DA
119 S DION="N"
120 ;
121 S DIUNIQ=1,DINS=$QL(DIUIR),DINDX=DIUIR
122 F S DINDX=$Q(@DINDX) Q:DINDX="" Q:$NA(@DINDX,DINS)'=DIUIR D Q:'DIUNIQ
123 . ;Set DA array, quit if this is index for current record
124 . S DIIENS=$E(DINDX,$L(DIUIR)+1,$L(DINDX)-1),L=$L(DIIENS,",")
125 . S DA=$P(DIIENS,",",L) F I=1:1:L-1 S DA(I)=$P(DIIENS,",",L-I)
126 . S DIIENS=$$IENS(.DA) Q:DIIENS=DIIENSC
127 . ;
128 . ;If values for this record are being updated via the FDA, don't
129 . ;bother checking (used by DIEVK)
130 . I $G(DIEVK) Q:$D(^TMP("DIKK",$J,"L",$P(DIEVK,U),$P(DIEVK,U,2),DIIENS)) Q:$D(^TMP("DIKK",$J,"F",$P(DIEVK,U),$P(DIEVK,U,2),DIIENS))
131 . ;
132 . ;If no values in index were truncated, values are not unique.
133 . I '$D(DIVAL) S DIUNIQ=0 Q
134 . ;
135 . ;Set the X array for the indexed record and compare
136 . S DIS=0 F S DIS=$O(DIVAL(DIS)) Q:'DIS X DISS(DIS) I X'=DIVAL(DIS) Q
137 . S:'DIS DIUNIQ=0
138 ;
139 K DA M DA=DIDASV
140 Q DIUNIQ
141 ;
142KEYCHK(DIFIL,DA,DIFLD,DIXREF,DIIENS,DITAR,DINEW) ;Check whether indexes
143 ;in @DIXREF are unique
144 N DIKEY,DIUINDEX,DIUNIQ,X
145 I $G(DITAR)]"",$G(DIIENS)="" S DIIENS=$$IENS(.DA)
146 ;
147 S DIUNIQ=1,DIKEY=0
148 F S DIKEY=$O(^DD("KEY","F",DIFIL,DIFLD,DIKEY)) Q:'DIKEY D Q:'DIUNIQ
149 . S DIUINDEX=$P(^DD("KEY",DIKEY,0),U,4)
150 . Q:'DIUINDEX!'$D(@DIXREF@(DIFIL,DIUINDEX))
151 . D SETXARR^DIKC(DIFIL,DIUINDEX,DIXREF,"",DINEW)
152 . S DIUNIQ=$$UNIQUE(DIFIL,DIUINDEX,.X,.DA,DIXREF)
153 . I 'DIUNIQ,$G(DITAR)]"" D SETK^DIKK(DIFIL,DIIENS,DIKEY,DITAR) S DIUNIQ=1
154 I $G(DITAR)]"",$D(@DITAR) S DIUNIQ=0
155 Q DIUNIQ
156 ;
157IENS(DA) ;Return IENS from DA array
158 N I,IENS
159 S IENS=$G(DA)_"," F I=1:1:$O(DA(" "),-1) S IENS=IENS_DA(I)_","
160 Q IENS
Note: See TracBrowser for help on using the repository browser.