DIT ;SFISC/GFT-GET XFR ANSWERS ;14FEB2005
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
;;
0 S DIC="^DOPT(""DIT""," G OPT:$D(^DOPT("DIT",3)) S ^(0)="TRANSFER OPTION^1.01" K ^("B")
F X=1,2,3 S ^DOPT("DIT",X,0)=$P("TRANSFER FILE ENTRIES^COMPARE/MERGE FILE ENTRIES^NAMESPACE COMPARE",U,X)
S DIK=DIC D IXALL^DIK
OPT W !! S DIC(0)="AEQZI" D ^DIC G Q:Y<0,UCI^DITCP:+Y=3 I +Y=2 D ^DITM K DIC G 0
D Q S DLAYGO=1 D W^DICRW G Q:$D(DTOUT) Q:Y<0 S DFL=$P(Y,U,2)_": " I '$D(DIC) D DIE^DIB Q:'$D(DG) S L=DG,Y=DLAYGO K DG,DIE,DQ G FROM
S DIC("B")=+Y,L=DIC
FROM S DMRG=1,DKP=1,(DDF(1),DDT(0))=+Y,DIC=1,DIC(0)="EQAZ",DIC("A")="TRANSFER FROM FILE: "
S DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
D ^DIC K DIC G Q:Y<0,Q:'$D(^(0,"GL")) S DTO=^("GL") I DUZ(0)'="@",$S($D(^VA(200,DUZ,"FOF",+Y,0)):1,1:$D(^DIC(3,DUZ,"FOF",+Y,0))) G DTR:+$P(^(0),U,3),Q
I DUZ(0)'="@",$D(^DIC(+Y,0,"DEL")) F X=1:1 G Q:X>$L(^("DEL")) Q:DUZ(0)[$E(^("DEL"),X)
DTR D PTS I +Y=DDF(1) G ^DIT0
TWO S (DTO(0),F)=L,L(+Y)=DDT(0),L=0,DDF(1)=+Y,DFR(1)=DTO_"D0,",DHIT=DLAYGO-(Y#1),%=0
W !! K ^UTILITY("DITR",$J),A I DLAYGO-1 W "DO YOU WANT TO TRANSFER THE '",$P(Y,U,2),"'",!,"DATA DICTIONARY INTO YOUR NEW FILE" D YN^DICN G Q:%<1 D ^DIT1:%=1
K DITF,Y,B W ! G Q:'$D(L)
D MAP I '$D(DITF) W $C(7),"FILES DON'T MATCH!" G Q
W:$X>40 ! W:'$D(A) " WILL BE TRANSFERRED",!!
S %=2,DMRG=0 I @("$O("_DTO(0)_"0))>0") W !,"WANT TO MERGE TRANSFERRED ENTRIES WITH ONES ALREADY THERE" D YN^DICN G Q:%<1 I %=1 S DMRG=1
S (DIK,DIC)=DTO,DTO=1,L="TRANSFER ENTRIES",FLDS="",DHD="@",%ZIS="F"
D S %=0 W !,"WANT EACH ENTRY TO BE DELETED AS IT'S TRANSFERRED" D YN^DICN S DHIT="S DI=99 D F^DITR"_$P(",^DIK",%,%=1) G Q:%<0 I '% D F G D
S DISTOP=0,DIOEND="S DIK=DTO(0),DIK(0)=""B"" D KL^DIT,IXALL^DIK,Q^DIT" D EN1^DIP
Q ;
K ^UTILITY("DITR",$J),^UTILITY("DIT",$J),DIT,DIC,DA,DB1,DFR,DIK,L,FLDS,DHIT,DISTOP,DIOEND,%ZIS
KL K DIU,DIV,DIG,DIH,DLAYGO,DITF,DFN,DMRG,DTO,DTN,DDF,DTL,DFL,DDT,A,B,DKP,W,X,FLDS,Y,Z Q
;
MAP ;BUILD MAP OF FIELDS FROM 'FROM' TO 'TO' FILE
N DFL S DFL=1
MAP2 ;ENTRY POINT FROM ^DIT3
K:L]"" L(L) S L=$O(L(0)) Q:L']""
F Y=0:0 S Y=$O(^DD(L,Y)) G MAP2:Y="",MAP2:'$D(^(Y,0)) S %=^(0) I $P(%,U,2)'["C" S DIC=$P(%,U,1),X=$O(^DD(L(L),"B",DIC,0)) I X>0,'^(X),$P(^DD(L(L),X,0),U,2)'["C" D T
Q
T S Z=$P(^(0),U,4),V=$P($P(^(0),U,2),U,Z[";0"),^UTILITY("DITR",$J,L,Y)=$P(Z,";",2)_U_$P(Z,";",1) S:V ^(Y)=^(Y)_U_V,L(+$P(%,U,2))=+V I Z="0;1",DDF(DFL)=L S DITF=$P(%,U,4)
Q:$D(A) W:$X ", " W:$L(DIC)+$X>66 ! W "'"_DIC_"' FIELDS" Q
;
PTS ;Find re-pointable fields (not containing "I"!)
S DL=0 F X=0:0 S X=$O(^DD(+Y,0,"PT",X)) Q:X'>0 F Z=.001:0 S Z=$O(^DD(+Y,0,"PT",X,Z)) Q:Z'>0 I $D(^DD(X,Z,0))#2 S %=^(0) I (U_$P(%,U,3)=DTO!($D(^DD(X,Z,"V","B",+Y)))),$P(%,U,2)'["I" S DL=DL+1,^UTILITY("DIT",$J,0,DL)=X_U_Z_U_$P(%,U,2)
Q
;
F W !?7,"(TYPE '^' TO FORGET THE WHOLE THING!)",!
Q
;
TRNMRG(DIFLG,DIFFNO,DITFNO,DIFIEN,DITIEN) ; SILENT TRANSFER/MERGE OF SINGLE RECORDS IN FILE OR SUBFILE
;DIFLG = FLAGS
;DIFFNO = TRANSFER 'FROM' FILE/SUBFILE NO. OR ROOT
;DITFNO = TRANSFER 'TO' FILE/SUBFILE NO.
;DIFIEN = TRANSFER 'FROM' IEN STRING
;DITIEN = TRANSFER 'TO' IEN STRING (PASS BY REFERENCE)
G TRNMRG^DIT3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIT 3463 printed Oct 16, 2024@18:54:35 Page 2
DIT ;SFISC/GFT-GET XFR ANSWERS ;14FEB2005
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;;
0 SET DIC="^DOPT(""DIT"","
if $DATA(^DOPT("DIT",3))
GOTO OPT
SET ^(0)="TRANSFER OPTION^1.01"
KILL ^("B")
+1 FOR X=1,2,3
SET ^DOPT("DIT",X,0)=$PIECE("TRANSFER FILE ENTRIES^COMPARE/MERGE FILE ENTRIES^NAMESPACE COMPARE",U,X)
+2 SET DIK=DIC
DO IXALL^DIK
OPT WRITE !!
SET DIC(0)="AEQZI"
DO ^DIC
if Y<0
GOTO Q
if +Y=3
GOTO UCI^DITCP
IF +Y=2
DO ^DITM
KILL DIC
GOTO 0
+1 DO Q
SET DLAYGO=1
DO W^DICRW
if $DATA(DTOUT)
GOTO Q
if Y<0
QUIT
SET DFL=$PIECE(Y,U,2)_": "
IF '$DATA(DIC)
DO DIE^DIB
if '$DATA(DG)
QUIT
SET L=DG
SET Y=DLAYGO
KILL DG,DIE,DQ
GOTO FROM
+2 SET DIC("B")=+Y
SET L=DIC
FROM SET DMRG=1
SET DKP=1
SET (DDF(1),DDT(0))=+Y
SET DIC=1
SET DIC(0)="EQAZ"
SET DIC("A")="TRANSFER FROM FILE: "
+1 SET DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
+2 DO ^DIC
KILL DIC
if Y<0
GOTO Q
if '$DATA(^(0,"GL"))
GOTO Q
SET DTO=^("GL")
IF DUZ(0)'="@"
IF $SELECT($DATA(^VA(200,DUZ,"FOF",+Y,0)):1,1:$DATA(^DIC(3,DUZ,"FOF",+Y,0)))
if +$PIECE(^(0),U,3)
GOTO DTR
GOTO Q
+3 IF DUZ(0)'="@"
IF $DATA(^DIC(+Y,0,"DEL"))
FOR X=1:1
if X>$LENGTH(^("DEL"))
GOTO Q
if DUZ(0)[$EXTRACT(^("DEL"),X)
QUIT
DTR DO PTS
IF +Y=DDF(1)
GOTO ^DIT0
TWO SET (DTO(0),F)=L
SET L(+Y)=DDT(0)
SET L=0
SET DDF(1)=+Y
SET DFR(1)=DTO_"D0,"
SET DHIT=DLAYGO-(Y#1)
SET %=0
+1 WRITE !!
KILL ^UTILITY("DITR",$JOB),A
IF DLAYGO-1
WRITE "DO YOU WANT TO TRANSFER THE '",$PIECE(Y,U,2),"'",!,"DATA DICTIONARY INTO YOUR NEW FILE"
DO YN^DICN
if %<1
GOTO Q
if %=1
DO ^DIT1
+2 KILL DITF,Y,B
WRITE !
if '$DATA(L)
GOTO Q
+3 DO MAP
IF '$DATA(DITF)
WRITE $CHAR(7),"FILES DON'T MATCH!"
GOTO Q
+4 if $X>40
WRITE !
if '$DATA(A)
WRITE " WILL BE TRANSFERRED",!!
+5 SET %=2
SET DMRG=0
IF @("$O("_DTO(0)_"0))>0")
WRITE !,"WANT TO MERGE TRANSFERRED ENTRIES WITH ONES ALREADY THERE"
DO YN^DICN
if %<1
GOTO Q
IF %=1
SET DMRG=1
+6 SET (DIK,DIC)=DTO
SET DTO=1
SET L="TRANSFER ENTRIES"
SET FLDS=""
SET DHD="@"
SET %ZIS="F"
D SET %=0
WRITE !,"WANT EACH ENTRY TO BE DELETED AS IT'S TRANSFERRED"
DO YN^DICN
SET DHIT="S DI=99 D F^DITR"_$PIECE(",^DIK",%,%=1)
if %<0
GOTO Q
IF '%
DO F
GOTO D
+1 SET DISTOP=0
SET DIOEND="S DIK=DTO(0),DIK(0)=""B"" D KL^DIT,IXALL^DIK,Q^DIT"
DO EN1^DIP
Q ;
+1 KILL ^UTILITY("DITR",$JOB),^UTILITY("DIT",$JOB),DIT,DIC,DA,DB1,DFR,DIK,L,FLDS,DHIT,DISTOP,DIOEND,%ZIS
KL KILL DIU,DIV,DIG,DIH,DLAYGO,DITF,DFN,DMRG,DTO,DTN,DDF,DTL,DFL,DDT,A,B,DKP,W,X,FLDS,Y,Z
QUIT
+1 ;
MAP ;BUILD MAP OF FIELDS FROM 'FROM' TO 'TO' FILE
+1 NEW DFL
SET DFL=1
MAP2 ;ENTRY POINT FROM ^DIT3
+1 if L]""
KILL L(L)
SET L=$ORDER(L(0))
if L']""
QUIT
+2 FOR Y=0:0
SET Y=$ORDER(^DD(L,Y))
if Y=""
GOTO MAP2
if '$DATA(^(Y,0))
GOTO MAP2
SET %=^(0)
IF $PIECE(%,U,2)'["C"
SET DIC=$PIECE(%,U,1)
SET X=$ORDER(^DD(L(L),"B",DIC,0))
IF X>0
IF '^(X)
IF $PIECE(^DD(L(L),X,0),U,2)'["C"
DO T
+3 QUIT
T SET Z=$PIECE(^(0),U,4)
SET V=$PIECE($PIECE(^(0),U,2),U,Z[";0")
SET ^UTILITY("DITR",$JOB,L,Y)=$PIECE(Z,";",2)_U_$PIECE(Z,";",1)
if V
SET ^(Y)=^(Y)_U_V
SET L(+$PIECE(%,U,2))=+V
IF Z="0;1"
IF DDF(DFL)=L
SET DITF=$PIECE(%,U,4)
+1 if $DATA(A)
QUIT
if $X
WRITE ", "
if $LENGTH(DIC)+$X>66
WRITE !
WRITE "'"_DIC_"' FIELDS"
QUIT
+2 ;
PTS ;Find re-pointable fields (not containing "I"!)
+1 SET DL=0
FOR X=0:0
SET X=$ORDER(^DD(+Y,0,"PT",X))
if X'>0
QUIT
FOR Z=.001:0
SET Z=$ORDER(^DD(+Y,0,"PT",X,Z))
if Z'>0
QUIT
IF $DATA(^DD(X,Z,0))#2
SET %=^(0)
IF (U_$PIECE(%,U,3)=DTO!($DATA(^DD(X,Z,"V","B",+Y))))
IF $PIECE(%,U,2)'["I"
SET DL=DL+1
SET ^UTILITY("DIT",$JOB,0,DL)=X_U_Z_U_$PIECE(%,U,2)
+2 QUIT
+3 ;
F WRITE !?7,"(TYPE '^' TO FORGET THE WHOLE THING!)",!
+1 QUIT
+2 ;
TRNMRG(DIFLG,DIFFNO,DITFNO,DIFIEN,DITIEN) ; SILENT TRANSFER/MERGE OF SINGLE RECORDS IN FILE OR SUBFILE
+1 ;DIFLG = FLAGS
+2 ;DIFFNO = TRANSFER 'FROM' FILE/SUBFILE NO. OR ROOT
+3 ;DITFNO = TRANSFER 'TO' FILE/SUBFILE NO.
+4 ;DIFIEN = TRANSFER 'FROM' IEN STRING
+5 ;DITIEN = TRANSFER 'TO' IEN STRING (PASS BY REFERENCE)
+6 GOTO TRNMRG^DIT3
