- 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 Jan 18, 2025@03:55:01 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