source: cprs/branches/tmg-cprs/m_files/TMGDIT0.m@ 1085

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

Initial upload

File size: 3.1 KB
Line 
1TMGDIT0 ;SFISC/XAK-PREPARE TO XFR ;09:21 AM Jul 19, 1988
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;"Copied from FM, for customization
5
6 K Y,DIC
7 S DIT=DDF(1)
8 S DIC=L
9 S DIC(0)="EQLAM"
10 S X="DATA INTO WHICH "
11 D LK ;"--> ^DIC Asks for destination record, and creates new if needed. Y=destination record
12 G Q:Y<0 ;"abort if requested
13 S DFR=+Y
14 S DTO(1)=DIC_+Y_"," ;"DTO is DESTINATION info array
15 ;"At this point we have:
16 ;" DTO=^VA(200,
17 ;" DTO(1) = ^VA(200,166,
18 S DIC(0)="EQAM",X="FROM ",DIC("S")="I Y-"_+Y
19 D LK ;"--> ^DIC Asks for source record.
20 G Q:Y<0 ;"abort if requested
21S S %=2 ;"default to NO delete
22 ;"//ktW !," WANT TO DELETE THIS ENTRY AFTER IT'S TRANSFERRED"
23 ;"//ktD YN^DICN ;"%=1 for YES, %=2 for NO
24 G Q:%<0 ;"abort if requested
25 S DH=2-% ;"DH=1 for delete, DH=0 for NO delete
26 I '% do goto S ;"loop back
27 . do F^TMGDIT
28 S ^UTILITY("DIT",$J,+Y)=DFR_";"_$E(DIC,2,999)
29 S DTO=0
30 S (D0,DA)=+Y
31 S DIK=DIC
32 S DFR(1)=DIC_DA_","
33 K DIC
34 D WAIT^DICD ;"Let me put you on hold...
35GO D GO^DITR ;"Find fields to XRef
36 S DIT=DH
37 D KL^TMGDIT
38 D ^DIK:DH ;"kill record if prev requested (I think)
39 S DA=DFR
40 K DFR
41 D IX1^DIK
42
43 S DH=DIT
44 set %=2 ;"//kt added
45 ;"//ktD ASK^DITP ;"Ask, redirect pointers? %: 1=yes, 2=no
46 ;"//ktD PTS^DITP:%=1
47Q G Q^TMGDIT
48 ;
49LK S DIC("A")="TRANSFER "_X_DFL
50 G ^DIC
51 ;
52EN ; PROGRAMMER CALL
53 ; DIT("F") = GLOBAL ROOT OR FILE # OF FILE TO TRANSFER FROM
54 ; DIT("T") = GLOBAL ROOT OR FILE # OF FILE TO TRANSFER TO
55 ; DA("F") = ENTRY # IN FILE TO TRANSFER FROM
56 ; DA("T") = ENTRY # IN FILE TO TRANSFER TO
57 ;" //kt: Note: this does not delete the FROM record
58 ;
59 I '$D(DIT("F"))!'$D(DIT("T"))!'$D(DA("F"))!'$D(DA("T")) G FIN
60 S DDF(1)=DIT("F")
61 S DDT(0)=DIT("T")
62 I 'DDF(1) do goto FIN:'DDF(1)
63 . set DDF(1)=$piece($get(@(DDF(1)_"0")),"^",2)
64 . if DDF(1)="" set DDF(1)=0
65 . ;"S DDF(1)=$S($D(@(DDF(1)_"0)"))#2:+$P(^(0),U,2),1:0)
66 . Q:'DDF(1)
67 . S DFR(1)=DIT("F")
68 I 'DDT(0) do G FIN:'DDT(0) goto C
69 . S DDT(0)=$S($D(@(DDT(0)_"0)"))#2:+$P(^(0),U,2),1:0)
70 . quit:'DDT(0)
71 . S DTO(1)=DIT("T")
72 G FIN:'$D(^DIC(+DDF(1),0,"GL"))
73 S DFR(1)=^("GL")
74 G FIN:'$D(^DIC(+DDT(0),0,"GL"))
75 S DTO(1)=^("GL")
76C S DB=DA("F")
77 S (DB1,DFR)=DA("T")
78 S DIK=DTO(1)
79 I $D(DA(1)) F I=1:1 G:'$D(DA(I)) SET do
80 . S DRF(I)=$P(DA(I),",",1)_",1,"
81 . S DOT(I)=$P(DA(I),",",2)_",1,"
82
83DON K DRF,DOT
84 S DFR(1)=DFR(1)_DB_","
85 S DTO(1)=DTO(1)_DB1_","
86 S DKP=1,DMRG=1,DTO=0,DH=0
87 G GO
88
89SET F I=I-1:-1 G:I'>0 DON do
90 . S DFR(1)=DFR(1)_DRF(I)
91 . S DTO(1)=DTO(1)_DOT(I)
92FIN ;
93 K DDF,DFR,DDT,DTO
94 Q
Note: See TracBrowser for help on using the repository browser.