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

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

initial load of WorldVistAEHR
File size: 6.4 KB
Line 
1DICA ;SEA/TOAD-VA FileMan, Updater, Engine ;1:33 PM 18 Nov 1999
2 ;;22.0;VA FileMan;**1,4,17**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ADD(DIFLAGS,DIFDA,DIEN,DIMSGA) ;
6 ;
7ADDX ; Branch in from UPDATE^DIE
8 ; ENTRY POINT--add a new entry to a file
9 ; subroutine, DIEN passed by reference
10 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
11 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
12 N DICLERR S DICLERR=$G(DIERR) K DIERR
13INPUT ;
14 ; initialize input parameters & check
15 N DIRULE S DIRULE=$$GETTMP^DIKC1("DICA")
16 N DIFDAO
17 S DIFLAGS=$G(DIFLAGS)
18 I $TR(DIFLAGS,"EKSUY")'="" D Q
19 . D ERR^DICA3(301,"","","",DIFLAGS),CLOSE
20 S DIFDA=$G(DIFDA) I $D(@DIFDA)<10 D Q
21 . D ERR^DICA3(202,"","","","FDA"),CLOSE
22 S DIFDAO=DIFDA
23 S DIEN=$G(DIEN) I DIEN="" S DIEN="DIDUMMY" N DIDUMMY
24PRE ;
25 N DIOK S DIOK=1 D CHECK^DICA1(DIFLAGS,.DIFDA,DIEN,DIRULE,.DIOK)
26 I $G(DIERR) D CLOSE Q
27 I 'DIOK D ERR^DICA3(202,"","","","FDA"),CLOSE Q
28SEQ ;
29 N DICHECK,DIENTRY,DIFILE,DIOUT1,DINEXT
30 S (DIOUT1,DINEXT)="" F D Q:DIOUT1
31 . S DINEXT=$O(@DIRULE@("NEXT",DINEXT)) I DINEXT="" S DIOUT1=1 Q
32 . X @DIRULE@("NEXT",DINEXT)
33FILES . ;
34 . I $P($G(^DD($$FNO^DILIBF(DIFILE),0,"DI")),U,2)["Y" D Q:DIOUT1
35 . . S DIOUT1=DIFLAGS'["Y"&'$D(DIOVRD)
36 . . I DIOUT1 D ERR^DICA3(405,DIFILE,"","",DIFILE)
37ENTRIES . ;
38 . N DIDA,DIENP,DIOP,DIROOT,DISEQ
39 . S DIDA=$P(DIENTRY,",") I +DIDA=DIDA Q
40 . S DIENP=$$IEN(DIENTRY,"",DIRULE)
41 . S DIOP=$E(DIDA,1,2) I DIOP'="?+" S DIOP=$E(DIOP)
42 . S DISEQ=$P(DIDA,DIOP,2)
43FINDING . ;
44 . ; Finding (?) or LAYGO/FInding (?+) nodes
45 . I DIOP["?" D Q
46 . . I DIOP="?+",DIENP[",," S @DIRULE@("NEXTADD",DINEXT)=@DIRULE@("NEXT",DINEXT) Q
47 . . N DIFIND,DIFORMAT,DIGET,DIINDEX,DIVALUE
48 . . S DIFORMAT="B"_$S(DIFLAGS["E":"",1:"Q")_$S(DIOP="?+":"X",1:"")
49 . . S DIGET=DIFDA
50 . . I DIFLAGS["E",DIOP["?" S DIGET=DIFDAO
51 . . I DIFLAGS["K",$D(^TMP("DIKK",$J,"P",DIFILE))#2 D
52 . . . D GETKVALS(.DIVALUE,.DIINDEX)
53 . . E S DIVALUE=$G(@DIGET@(DIFILE,DIENTRY,.01))
54 . . S DIFIND=$$FIND1^DIC(DIFILE,DIENP,DIFORMAT,.DIVALUE,$G(DIINDEX))
55 . . I $G(DIERR) S DIOUT1=1 Q
56 . . I DIOP="?+",'DIFIND S @DIRULE@("NEXTADD",DINEXT)=@DIRULE@("NEXT",DINEXT) Q
57 . . I 'DIFIND S DIOUT1=1 D Q
58 . . . I $D(DIVALUE)=10 N I,Q S DIVALUE="",(I,Q)=0 F S I=$O(DIVALUE(I)) Q:'I D Q:Q
59 . . . . Q:DIVALUE(I)=""
60 . . . . S:DIVALUE]"" DIVALUE=DIVALUE_";"
61 . . . . I $L(DIVALUE)+$L(DIVALUE(I))>252 D
62 . . . . . S DIVALUE=$E(DIVALUE,1,252)_$E(DIVALUE(I),1,252-$L(DIVALUE))_"..."
63 . . . . . S Q=1
64 . . . . E S DIVALUE=$G(DIVALUE)_$E(DIVALUE(I),1,251)
65 . . . D ERR^DICA3(703,DIFILE,DIENTRY,"",DIVALUE)
66 . . S @DIEN@(DISEQ)=DIFIND
67 . . I DIOP="?+" S @DIEN@(DISEQ,0)="?"
68 . . S @DIRULE@("IEN",DISEQ)=DIFIND
69 . . I DIFLAGS["K",$D(^TMP("DIKK",$J,"P",DIFILE)) D SAVEK Q
70 . . D SAVE
71 . ; Adding (+) nodes
72 . I '$G(DICHECK) S DICHECK=1 D ADDLF S:DIENP[",," DIENP=$$IEN(DIENTRY,"",DIRULE) I $G(DIERR) S DIOUT1=1 Q
73 . D ADDING
74 ;
75FILER ; file the data for the new records
76 I '$G(DIERR),$D(@DIFDA) D
77 . I '$G(DICHECK) D ADDLF Q:$G(DIERR)!'$D(@DIFDA)
78 . D FILE^DIEF($E("S",DIFLAGS["S")_"U",DIFDA,"",DIEN)
79 I '$G(DIERR),DIFLAGS'["S" K @DIFDAO
80 I $G(DIERR)!(DIFLAGS["S"),DIFLAGS'["E" D
81 . M @DIFDA=@DIRULE@("SAVE")
82 D CLOSE
83 Q
84 ;
85ADDING ;
86 N DIENEW,DIKEY
87 I $L(DIENP,",")>2 S DIOK=$$VMINUS9^DIEFU(DIFILE,DIENP) I 'DIOK D Q
88 . S DIOUT1=1
89 . D ERR^DICA3(602,DIFILE,$P(DIENP,",",$L(DIENP,",")-1))
90 S DIROOT=$$ROOT^DIQGU(DIFILE,DIENP)
91 D DA^DILF(DIENTRY,.DIENEW)
92A1 S DIENEW=$$IEN(DIENTRY,$G(@DIEN@(DISEQ)),DIRULE)
93 S DIKEY=$G(@DIFDA@(DIFILE,DIENTRY,.01)) I DIKEY="" D Q
94 . S DIOUT1=1 D ERR^DICA3(202,"","","","FDA")
95 S DIOK=$$LAYGO(DIFILE,.DIENEW,DIKEY)
96 I 'DIOK S DIOUT1=1 D Q
97 . I '$G(DIERR) D ERR^DICA3(405,DIFILE,"","",DIFILE) Q
98 . N DIENS S DIENS="New entry"
99 . I $L(DIENEW,",")>2 S DIENS=DIENS_" under record: "_DIENEW
100 . N DI1 S DI1="LAYGO Node on the new value '"_DIKEY_"'"
101 . D ERR^DICA3(120,DIFILE,DIENS,.01,DI1)
102 D CREATE^DICA3(DIFILE,.DIENEW,DIROOT,DIKEY)
103 S DIENEW=+DIENEW
104 I 'DIENEW S DIOUT1=1 Q
105 L -@(DIROOT_"DIENEW)")
106 S @DIEN@(DISEQ)=DIENEW
107 I DIOP="?+" S @DIEN@(DISEQ,0)="+"
108 S @DIRULE@("IEN",DISEQ)=DIENEW
109 D SAVE
110 Q
111 ;
112LAYGO(DIFILE,DIEN,DIKEY) ;
113 ; ADDING--return if LAYGO permitted
114 ; function, all by value
115 N DA,DIOK,DINODE,DIOUTS,X,Y,Y1
116 S DIOK=1,DINODE="",DIOUTS=0 F D I DIOUTS!'DIOK Q
117 . S DINODE=$O(^DD(DIFILE,.01,"LAYGO",DINODE))
118 . I DINODE'>0 S DIOUTS=1 Q
119 . I $D(^DD(DIFILE,.01,"LAYGO",DINODE,0))[0 Q
120 . S X=DIKEY M DA=DIEN S Y=$P(DA,","),Y1=DA,DA=$P(DA,",")
121 . I 1 X ^DD(DIFILE,.01,"LAYGO",DINODE,0) S DIOK=$T&'$G(DIERR)
122 Q DIOK
123 ;
124SAVE I DIFLAGS'["E" D
125 . S @DIRULE@("SAVE",DIFILE,DIENTRY,.01)=@DIFDA@(DIFILE,DIENTRY,.01)
126 K @DIFDA@(DIFILE,DIENTRY,.01)
127 Q
128 ;
129SAVEK ; Remove primary key field from FDA; save in ^TMP first if necessary
130 N DIFLD
131 S DIFLD=0
132 F S DIFLD=$O(^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD)) Q:'DIFLD D
133 . Q:'^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD)
134 . Q:$D(@DIGET@(DIFILE,DIENTRY,DIFLD))[0
135 . S:DIFLAGS'["E" @DIRULE@("SAVE",DIFILE,DIENTRY,DIFLD)=@DIFDA@(DIFILE,DIENTRY,DIFLD)
136 . K @DIFDA@(DIFILE,DIENTRY,DIFLD)
137 Q
138 ;
139IEN(DIENTRY,DIENF,DIRULE) ;
140 ; ADDING/FINDING--return translated IEN String
141 ; function, DIENTRY passed by value
142 N DIC,DIENEW,DIOP,DIP,DIPNEW,DISEQ
143 S DIENEW=""
144 S DIENF=$G(DIENF)
145 S DIP="" F DIC=1:1 D I DIP="" Q
146 . S DIP=$P(DIENTRY,",",DIC) I DIP="" Q
147 . D
148 . . I +DIP=DIP S DIPNEW=DIP Q
149IEN1 . . I DIC=1 S DIPNEW=DIENF Q
150 . . S DIOP=$E(DIP,1,2) I DIOP'="?+" S DIOP=$E(DIOP)
151 . . S DISEQ=$P(DIP,DIOP,2,9999)
152 . . S DIPNEW=$G(@DIRULE@("IEN",DISEQ))
153 . S $P(DIENEW,",",DIC)=DIPNEW
154 I DIENEW'="" S DIENEW=DIENEW_","
155 Q DIENEW
156 ;
157CLOSE I DICLERR'=""!$G(DIERR) D
158 . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
159 I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA)
160 K @DIRULE,^TMP("DIKK",$J)
161 Q
162 ;
163GETKVALS(DIVALUE,DIINDEX) ; Get primary key values and uniq index
164 N DIFLD,DIKEY,DISQ
165 K DIVALUE
166 S DIKEY=$P(^TMP("DIKK",$J,"P",DIFILE),U),DIINDEX=$P(^(DIFILE),U,4)
167 Q:DIINDEX=""!'DIKEY
168 ;
169 S DIFLD=0
170 F S DIFLD=$O(^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD)) Q:'DIFLD D
171 . S DISQ=^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD) Q:'DISQ
172 . Q:$D(@DIGET@(DIFILE,DIENTRY,DIFLD))[0
173 . S DIVALUE(DISQ)=@DIGET@(DIFILE,DIENTRY,DIFLD)
174 Q
175 ;
176ADDLF ; Check key integrity
177 I $D(^TMP("DIKK",$J,"L")),'$$CHECK^DIEVK(DIFDA,DIFLAGS,DIEN) Q
178 ;
179 ; Add records for LAYGO/Finding nodes which were not found
180 N DINEXT
181 S (DINEXT,DIOUT1)=""
182 F S DINEXT=$O(@DIRULE@("NEXTADD",DINEXT)) Q:DINEXT="" D Q:DIOUT1
183 . N DIENP,DIFILE,DIENTRY,DIOP,DIROOT,DISEQ
184 . X @DIRULE@("NEXTADD",DINEXT)
185 . S DIENP=$$IEN(DIENTRY,"",DIRULE)
186 . S DIOP="?+"
187 . S DISEQ=$P($P(DIENTRY,","),DIOP,2)
188 . D ADDING
189 Q
Note: See TracBrowser for help on using the repository browser.