- 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 Feb 19, 2025@00:20:18 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