| [796] | 1 | TMGDIT0 ;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
|
|---|
| 21 | S 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...
|
|---|
| 35 | GO 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
|
|---|
| 47 | Q G Q^TMGDIT
|
|---|
| 48 | ;
|
|---|
| 49 | LK S DIC("A")="TRANSFER "_X_DFL
|
|---|
| 50 | G ^DIC
|
|---|
| 51 | ;
|
|---|
| 52 | EN ; 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")
|
|---|
| 76 | C 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 |
|
|---|
| 83 | DON 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 |
|
|---|
| 89 | SET 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)
|
|---|
| 92 | FIN ;
|
|---|
| 93 | K DDF,DFR,DDT,DTO
|
|---|
| 94 | Q
|
|---|
