source: cprs/branches/tmg-cprs/m_files/TMGDIT.m@ 1742

Last change on this file since 1742 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload

File size: 7.6 KB
RevLine 
[796]1TMGDIT ;SFISC/GFT-GET XFR ANSWERS ;4/6/94 13:03
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4
5 ;"Copied from FM, for decompiling and modifications
6 ;"Revised interface added at end.
7
80 S DIC="^DOPT(""DIT"","
9 G OPT:$D(^DOPT("DIT",2))
10 S ^(0)="TRANSFER OPTION^1.01"
11 K ^("B")
12 F X=1,2 S ^DOPT("DIT",X,0)=$P("TRANSFER^COMPARE/MERGE",U,X)_" FILE ENTRIES"
13 S DIK=DIC
14 D IXALL^DIK
15OPT W !!
16 S DIC(0)="AEQZI"
17 ;"//ktD ^DIC ;"do menu asking for options --> Y=1^Transfer...
18 S Y=1 ;"//kt added
19 G Q:Y<0
20 I +Y=2 D ^DITM K DIC G 0 ;"2 --> compare/merge 2 entries
21 D Q ;"cleanup local variables.
22 S DLAYGO=1 ;"allow addition of new file, if wanted
23 D W^DICRW ;"ask 'INPUT TO WHAT FILE?' Y --> 200^NEW PERSON...
24 G Q:$D(DTOUT)
25 Q:Y<0
26 S DFL=$P(Y,U,2)_": "
27 I '$D(DIC) do Q:'$D(DG) G FROM
28 . D DIE^DIB
29 . Q:'$D(DG)
30 . S L=DG,Y=DLAYGO
31 . K DG,DIE,DQ
32 S DIC("B")=+Y ;"save destination file number
33 S L=DIC
34 ;
35FROM S DMRG=1,DKP=1,(DDF(1),DDT(0))=+Y,DIC=1,DIC(0)="EQAZ",DIC("A")="TRANSFER FROM FILE: "
36 S DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
37 D ^DIC ;"ask 'Transfer FROM which file? Y --> 200^Newperson...
38 K DIC
39 G Q:Y<0
40 G Q:'$D(^(0,"GL"))
41 S DTO=^("GL") ;"DTO = root of source file
42 I DUZ(0)'="@",$S($D(^VA(200,DUZ,"FOF",+Y,0)):1,1:$D(^DIC(3,DUZ,"FOF",+Y,0))) G DTR:+$P(^(0),U,3),Q
43 I DUZ(0)'="@",$D(^DIC(+Y,0,"DEL")) F X=1:1 G Q:X>$L(^("DEL")) Q:DUZ(0)[$E(^("DEL"),X)
44DTR D PTS ;"get pointers into ^UTILITY("DIT",$J,0,#)=File^Field^FieldDefInfo
45 I +Y=DDF(1)
46 G ^TMGDIT0 ;"prepare to transfer
47 ;"
48 ;"=============================================================
49TWO S (DTO(0),F)=L,L(+Y)=DDT(0),L=0,DDF(1)=+Y,DFR(1)=DTO_"D0,",DHIT=DLAYGO-(Y#1),%=0
50 W !!
51 K ^UTILITY("DITR",$J),A
52 I DLAYGO-1 do G Q:%<1
53 . W "DO YOU WANT TO TRANSFER THE '",$P(Y,U,2),"'",!
54 . W "DATA DICTIONARY INTO YOUR NEW FILE"
55 . D YN^DICN
56 . QUIT:%<1
57 . D ^DIT1:%=1
58
59 K DITF,Y,B
60 W !
61 G Q:'$D(L)
62 D MAP
63 I '$D(DITF) W $C(7),"FILES DON'T MATCH!" G Q
64 W:$X>40 ! W:'$D(A) " WILL BE TRANSFERRED",!!
65 S %=2,DMRG=0
66 I @("$O("_DTO(0)_"0))>0") W !,"WANT TO MERGE TRANSFERRED ENTRIES WITH ONES ALREADY THERE" D YN^DICN G Q:%<1 I %=1 S DMRG=1
67 S (DIK,DIC)=DTO,DTO=1,L="TRANSFER ENTRIES",FLDS="",DHD="@",%ZIS="F"
68D S %=0
69 W !,"WANT EACH ENTRY TO BE DELETED AS IT'S TRANSFERRED"
70 D YN^DICN
71 S DHIT="S DI=99 D F^DITR"_$P(",^DIK",%,%=1)
72 G Q:%<0
73 I '% D F G D
74 S DISTOP=0
75 s DIOEND="S DIK=DTO(0),DIK(0)=""B"" D KL^DIT,IXALL^DIK,Q^DIT"
76 D EN1^DIP
77Q ;
78 K ^UTILITY("DITR",$J),^UTILITY("DIT",$J),DIT,DIC,DA,DB1,DFR,DIK,L,FLDS,DHIT,DISTOP,DIOEND,%ZIS
79KL K DIU,DIV,DIG,DIH,DLAYGO,DITF,DFN,DMRG,DTO,DTN,DDF,DTL,DFL,DDT,A,B,DKP,W,X,FLDS,Y,Z
80 Q
81 ;
82MAP ;"BUILD MAP OF FIELDS FROM 'FROM' TO 'TO' FILE
83 N DFL
84 S DFL=1
85MAP2 ;"ENTRY POINT FROM ^DIT3
86 K:L]"" L(L)
87 S L=$O(L(0))
88 Q:L']""
89 F Y=0:0 S Y=$O(^DD(L,Y)) G MAP2:Y="",MAP2:'$D(^(Y,0)) S %=^(0) I $P(%,U,2)'["C" S DIC=$P(%,U,1),X=$O(^DD(L(L),"B",DIC,0)) I X>0,'^(X),$P(^DD(L(L),X,0),U,2)'["C" D T
90 Q
91 ;"
92T S Z=$P(^(0),U,4)
93 S V=$P($P(^(0),U,2),U,Z[";0")
94 S ^UTILITY("DITR",$J,L,Y)=$P(Z,";",2)_U_$P(Z,";",1)
95 S:V ^(Y)=^(Y)_U_V,L(+$P(%,U,2))=+V
96 I Z="0;1",DDF(DFL)=L
97 S DITF=$P(%,U,4)
98 Q:$D(A)
99 W:$X ", "
100 W:$L(DIC)+$X>66 !
101 W "'"_DIC_"' FIELDS"
102 Q
103 ;
104PTS ;
105 ;"Loads up ^UTILITY('DIT',$J) with pointers out (I think)
106 ;"Input: Y as filenumber
107 S DL=0
108 F X=0:0 S X=$O(^DD(+Y,0,"PT",X)) Q:X'>0 do
109 . F Z=.001:0 S Z=$O(^DD(+Y,0,"PT",X,Z)) Q:Z'>0 do
110 . . I '$D(^DD(X,Z,0))#2 quit
111 . . S %=^(0)
112 . . I '(U_$P(%,U,3)=DTO!($D(^DD(X,Z,"V","B",+Y)))) quit
113 . . I $P(%,U,2)'["I" do
114 . . . S DL=DL+1
115 . . . S ^UTILITY("DIT",$J,0,DL)=X_U_Z_U_$P(%,U,2)
116 Q
117 ;
118F W !?7,"(TYPE '^' TO FORGET THE WHOLE THING!)",!
119 Q
120 ;
121 ;"=============================================================
122 ;"=============================================================
123TRNMRG(DIFLG,DIFFNO,DITFNO,DIFIEN,DITIEN)
124 ;"Purpose: SILENT TRANSFER/MERGE OF SINGLE RECORDS IN FILE OR SUBFILE
125 ;"Input:
126 ;" DIFLG = FLAGS
127 ;" DIFFNO = TRANSFER 'FROM' FILE/SUBFILE NO. OR ROOT
128 ;" DITFNO = TRANSFER 'TO' FILE/SUBFILE NO.
129 ;" DIFIEN = TRANSFER 'FROM' IEN STRING
130 ;" DITIEN = TRANSFER 'TO' IEN STRING (PASS BY REFERENCE)
131 ;"
132 ;"//kt According to post from George Timpson, here is the
133 ;" definations for FLAGS:
134 ;" "M" Merge the two entries. -- If a field exists on the target
135 ;" record, do not write over it)
136 ;" "O" Overwrite the merge 'TO' entry. (if a field exists on the
137 ;" merge 'from' record, it overwrites the same field on the target record)
138 ;" "A" Add the new record. This does not look for a match, but always
139 ;" adds the merge 'from' record as a new entry in the target file.
140 ;" "R" Replace. (Used only for package installation). In ^DIT
141 ;" and ^DIT3, this works the same as 'O'. In replace mode, if a match
142 ;" is found between a record coming in with the installation and a
143 ;" record on the target system, the record on the target system is
144 ;" deleted, except for any locally developed fields. We haven't yet
145 ;" worked out the details of how this will be done. We may be setting
146 ;" a new internal flags to pass to ^DITR, based on this flag containing
147 ;" an "R". It seems to me that ^DITR would be the place to delete the
148 ;" existing record, if a match is found.
149 ;" "X" If this optional flag is included, the routine will run the SET
150 ;" cross-reference logic on the merged 'TO' record, after it has been
151 ;" installed.
152
153 G TRNMRG^DIT3
154
155 ;"=============================================================
156 ;"=============================================================
157
158XFERREC(File,FromIEN,ToIEN)
159 ;"Purpose:
160 ;"Input: FromFile -- IEN of file of source
161
162 new DIC
163 D Q2 ;"cleanup local variables.
164 set File=+$get(File)
165 if File'>0 quit
166 set ToIEN=+$get(ToIEN) ;"not supporting IENS right now.
167 if ToIEN'>0 quit
168 set FromIEN=+$get(FromIEN)
169 if FromIEN'>0 quit
170 S L=$get(^DIC(File,0,"GL"))
171 if L="" quit
172
173 S DMRG=1,DKP=1
174 S (DDF(1),DDT(0))=File
175 S DTO=L ;"DTO = root of source file
176 ;"D PTS ;"get pointers into ^UTILITY("DIT",$J,0,#)=File^Field^FieldDefInfo
177
178 ;"=============================================
179
180 K DIC
181 S DIC=L
182 set Y=ToIEN ;"//kt
183
184 S DFR=ToIEN
185 S DTO(1)=L_ToIEN_"," ;"DTO is DESTINATION info array
186 set Y=FromIEN ;"//kt
187
188 S ^UTILITY("DIT",$J,FromIEN)=ToIEN_";"_$E(L,2,999)
189 S DTO=0
190 S (D0,DA)=+Y
191 S DIK=L
192 S DFR(1)=L_DA_","
193 K DIC
194
195GO D GO^DITR ;"Find fields to XRef
196
197 D KL^TMGDIT
198 S DA=ToIEN
199 K DFR
200 D IX1^DIK ;"input: DIK (Root of file), DA (used as IEN)
201
202Q2 G Q^TMGDIT
203 ;
Note: See TracBrowser for help on using the repository browser.