DIT0.m

DIT0 ;SFISC/GFT,XAK-PREPARE TO XFR ;8AUG2011

 ;;22.0;VA FileMan;**168**;Mar 30, 1999;Build 27

 ;Per VHA Directive 2004-038, this routine should not be modified.

 N Y,DIC,DIT0KILL S DIT=DDF(1),DIC=L,DIC(0)="EQLAM",X="DATA INTO WHICH " D LK

 G Q:Y<0 S DFR=+Y,DTO(1)=DIC_+Y_",",DIC(0)="EQAM",X="FROM ",DIC("S")="I Y-"_+Y D LK G Q:Y<0

S S (D0,DA)=+Y W ! D  G Q:%<0 S (DH,DIT0KILL)=2-% I '% D F^DIT G S

 .I $D(^DD(DIT,.01,"DEL",1,0)) X ^(0) I  S %=2 Q

 .S %=2 W "   WANT TO DELETE THIS ENTRY AFTER IT'S TRANSFERRED" D YN^DICN

 S ^UTILITY("DIT",$J,+Y)=DFR_";"_$E(DIC,2,999)

 S DTO=0,DIK=DIC,DFR(1)=DIC_DA_"," K DIC D WAIT^DICD

GO D GO^DITR

 S DIT=DH D KL^DIT,^DIK:DIT0KILL S DA=DFR K DFR D IX1^DIK ;DELETE OLD ENTRY, CONDITIONALLY

 S DH=DIT D ASK^DITP,PTS^DITP:%=1

Q G Q^DIT

 ;

LK S DIC("A")="TRANSFER "_X_DFL G ^DIC

 ;

EN ; PROGRAMMER CALL

 ; DIT("F") = GLOBAL ROOT OR FILE # OF FILE TO TRANSFER FROM

 ; DIT("T") = GLOBAL ROOT OR FILE # OF FILE TO TRANSFER TO

 ; DA("F")  = ENTRY # IN FILE TO TRANSFER FROM

 ; DA("T")  = ENTRY # IN FILE TO TRANSFER TO

 ;

 I '$D(DIT("F"))!'$D(DIT("T"))!'$D(DA("F"))!'$D(DA("T")) G FIN

 S DDF(1)=DIT("F"),DDT(0)=DIT("T")

 I 'DDF(1) S DDF(1)=$S($D(@(DDF(1)_"0)"))#2:+$P(^(0),U,2),1:0) G FIN:'DDF(1) S DFR(1)=DIT("F")

 I 'DDT(0) S DDT(0)=$S($D(@(DDT(0)_"0)"))#2:+$P(^(0),U,2),1:0) G FIN:'DDT(0) S DTO(1)=DIT("T") G C

 G FIN:'$D(^DIC(+DDF(1),0,"GL")) S DFR(1)=^("GL")

 G FIN:'$D(^DIC(+DDT(0),0,"GL")) S DTO(1)=^("GL")

C S DB=DA("F"),(DB1,DFR)=DA("T"),DIK=DTO(1)

 I $D(DA(1)) F I=1:1 G:'$D(DA(I)) SET S DRF(I)=$P(DA(I),",",1)_",1,",DOT(I)=$P(DA(I),",",2)_",1,"

DON K DRF,DOT S DFR(1)=DFR(1)_DB_",",DTO(1)=DTO(1)_DB1_",",DKP=1,DMRG=1,DTO=0,DH=0 G GO

SET F I=I-1:-1 G:I'>0 DON S DFR(1)=DFR(1)_DRF(I),DTO(1)=DTO(1)_DOT(I)

FIN ;

 K DDF,DFR,DDT,DTO

 Q

DIT0      ;SFISC/GFT,XAK-PREPARE TO XFR ;8AUG2011

 +1       ;;22.0;VA FileMan;**168**;Mar 30, 1999;Build 27

 +2       ;Per VHA Directive 2004-038, this routine should not be modified.

 +3        NEW Y,DIC,DIT0KILL

           SET DIT=DDF(1)

           SET DIC=L

           SET DIC(0)="EQLAM"

           SET X="DATA INTO WHICH "

           DO LK

 +4        IF Y<0

               GOTO Q

           SET DFR=+Y

           SET DTO(1)=DIC_+Y_","

           SET DIC(0)="EQAM"

           SET X="FROM "

           SET DIC("S")="I Y-"_+Y

           DO LK

           IF Y<0

               GOTO Q

S          SET (D0,DA)=+Y

           WRITE !

           Begin DoDot:1

 +1            IF $DATA(^DD(DIT,.01,"DEL",1,0))

                   XECUTE ^(0)

                  IF $TEST

                       SET %=2

                       QUIT 

 +2            SET %=2

               WRITE "   WANT TO DELETE THIS ENTRY AFTER IT'S TRANSFERRED"

               DO YN^DICN

           End DoDot:1

           IF %<0

               GOTO Q

           SET (DH,DIT0KILL)=2-%

           IF '%

               DO F^DIT

               GOTO S

 +3        SET ^UTILITY("DIT",$JOB,+Y)=DFR_";"_$EXTRACT(DIC,2,999)

 +4        SET DTO=0

           SET DIK=DIC

           SET DFR(1)=DIC_DA_","

           KILL DIC

           DO WAIT^DICD

GO         DO GO^DITR

 +1       ;DELETE OLD ENTRY, CONDITIONALLY

           SET DIT=DH

           DO KL^DIT

           IF DIT0KILL

               DO ^DIK

           SET DA=DFR

           KILL DFR

           DO IX1^DIK

 +2        SET DH=DIT

           DO ASK^DITP

           IF %=1

               DO PTS^DITP

Q          GOTO Q^DIT

 +1       ;

LK         SET DIC("A")="TRANSFER "_X_DFL

           GOTO ^DIC

 +1       ;

EN        ; PROGRAMMER CALL

 +1       ; DIT("F") = GLOBAL ROOT OR FILE # OF FILE TO TRANSFER FROM

 +2       ; DIT("T") = GLOBAL ROOT OR FILE # OF FILE TO TRANSFER TO

 +3       ; DA("F")  = ENTRY # IN FILE TO TRANSFER FROM

 +4       ; DA("T")  = ENTRY # IN FILE TO TRANSFER TO

 +5       ;

 +6        IF '$DATA(DIT("F"))!'$DATA(DIT("T"))!'$DATA(DA("F"))!'$DATA(DA("T"))

               GOTO FIN

 +7        SET DDF(1)=DIT("F")

           SET DDT(0)=DIT("T")

 +8        IF 'DDF(1)

               SET DDF(1)=$SELECT($DATA(@(DDF(1)_"0)"))#2:+$PIECE(^(0),U,2),1:0)

               IF 'DDF(1)

                   GOTO FIN

               SET DFR(1)=DIT("F")

 +9        IF 'DDT(0)

               SET DDT(0)=$SELECT($DATA(@(DDT(0)_"0)"))#2:+$PIECE(^(0),U,2),1:0)

               IF 'DDT(0)

                   GOTO FIN

               SET DTO(1)=DIT("T")

               GOTO C

 +10       IF '$DATA(^DIC(+DDF(1),0,"GL"))

               GOTO FIN

           SET DFR(1)=^("GL")

 +11       IF '$DATA(^DIC(+DDT(0),0,"GL"))

               GOTO FIN

           SET DTO(1)=^("GL")

C          SET DB=DA("F")

           SET (DB1,DFR)=DA("T")

           SET DIK=DTO(1)

 +1        IF $DATA(DA(1))

               FOR I=1:1

                   IF '$DATA(DA(I))

                       GOTO SET

                   SET DRF(I)=$PIECE(DA(I),",",1)_",1,"

                   SET DOT(I)=$PIECE(DA(I),",",2)_",1,"

DON        KILL DRF,DOT

           SET DFR(1)=DFR(1)_DB_","

           SET DTO(1)=DTO(1)_DB1_","

           SET DKP=1

           SET DMRG=1

           SET DTO=0

           SET DH=0

           GOTO GO

SET        FOR I=I-1:-1

               IF I'>0

                   GOTO DON

               SET DFR(1)=DFR(1)_DRF(I)

               SET DTO(1)=DTO(1)_DOT(I)

FIN       ;

 +1        KILL DDF,DFR,DDT,DTO

 +2        QUIT