DIT0 ;SFISC/GFT,XAK-PREPARE TO XFR ;15FEB2013
;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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
K DA S DA=D0,DIT=DH D KL^DIT,^DIK:$G(DIT0KILL) S DA=DFR K DFR D IX1^DIK ;DELETE OLD ENTRY, CONDITIONALLY ;p14
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
;
N DIT0KILL
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,DIT0KILL=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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIT0 2048 printed Apr 09, 2024@21:47:02 Page 2
DIT0 ;SFISC/GFT,XAK-PREPARE TO XFR ;15FEB2013
+1 ;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 NEW Y,DIC,DIT0KILL
SET DIT=DDF(1)
SET DIC=L
SET DIC(0)="EQLAM"
SET X="DATA INTO WHICH "
DO LK
+8 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 ;p14
KILL DA
SET DA=D0
SET DIT=DH
DO KL^DIT
if $GET(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 NEW DIT0KILL
+7 IF '$DATA(DIT("F"))!'$DATA(DIT("T"))!'$DATA(DA("F"))!'$DATA(DA("T"))
GOTO FIN
+8 SET DDF(1)=DIT("F")
SET DDT(0)=DIT("T")
+9 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")
+10 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
+11 if '$DATA(^DIC(+DDF(1),0,"GL"))
GOTO FIN
SET DFR(1)=^("GL")
+12 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
SET DIT0KILL=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
