- DITM2 ;SFISC/JCM(OHPRD)-DOES COMPARE AND MERGE ;11/18/94 15:42
- ;;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.
- ;
- ; See DITMDOC for documentation
- ; Subfiles are not currently supported by the call to EN^DITM2
- ; until DITC can handle them.
- ;-------------------------------------------------------------------
- START ;
- EN ; Entry point
- L +@(DITM("DIC")_$P(DITM("DIT(1)"),",",1)_")")
- L +@(DITM("DIC")_$P(DITM("DIT(2)"),",",1)_")")
- K DMSG,DIRUT
- D:'$D(DITM("NON-INTERACTIVE")) DITC ; --->Sets up and calls DITC
- I $D(DMSG)!($D(DIRUT)) S DITM("QFLG")="" G END
- G:'$D(DITM("DIMERGE")) END
- D:'$D(DITM("SUB FILE")) DIT0 ; --->Sets up and calls DIT0
- D:$D(DITM("REPOINT"))&('$D(DITM("SUB FILE"))) REPOINT ;---->Merges
- ;---------------->other files that affect patient merge
- G:$D(DITM("QFLG")) END
- D:$D(DITM("DELETE")) DELETE ;----->Deletes MERGED entry
- END L -@(DITM("DIC")_$P(DITM("DIT(1)"),",",1)_")")
- L -@(DITM("DIC")_$P(DITM("DIT(2)"),",",1)_")")
- D EOJ ;----------->Cleanup
- Q ;-------------->End of routine
- ;----------------------------------------------------------------------
- DITC ;
- ;***Will need to add set up for subfiles when it works******
- ;
- K DFF,DIT,DIMERGE,DDIF,DDEF,DDSP
- S DFF=DITM("DFF"),DIT(1)=DITM("DIT(1)"),DIT(2)=DITM("DIT(2)"),DIC=DITM("DIC")
- S:$D(DITM("DIMERGE")) DIMERGE=1
- S:$D(DITM("DDIF")) DDIF=DITM("DDIF")
- S:$D(DITM("DDEF")) DDEF=DITM("DDEF")
- S:$D(DITM("DDSP")) DDSP=1
- D EN^DITC
- K DFF,DIT,DIMERGE,DDIF,DDEF,DDSP
- Q
- DIT0 ;
- W:'$D(DITM("NOTALK")) !!,"I will now merge all subfiles in this file ...",!,"This may take some time, please be patient."
- K DA
- S (DIT("T"),DIT("F"))=DITM("DIC")
- S (D0,DA("T"))=DITM("DIT(2)"),DA("F")=DITM("DIT(1)")
- D EN^DIT0 K D0,DA,DIC,DIK,DIT
- Q
- REPOINT ;
- S DITMGMQF=0
- S:$D(DITM("NON-INTERACTIVE")) DITMGMRG("NOTALK")=1
- S:$D(DITM("PACKAGE")) DITMGMRG("PACKAGE")=DITM("PACKAGE")
- W:'$D(DITM("NOTALK")) !!,"I will now repoint all files that point to this entry ...",!,"This may take some time, please be patient."
- S DITMGMRG("FILE")=DITM("DFF"),DITMGMRG("FR")=DITM("DIT(1)"),DITMGMRG("TO")=DITM("DIT(2)")
- S:$D(DITM("NOTALK")) DITMGMRG("NOTALK")=""
- I $D(DITM("EXCLUDE")) F DITMI=0:0 S DITMI=$O(DITM("EXCLUDE",DITMI)) Q:'DITMI S DITMGMRG("EXCLUDE",DITMI)=""
- D EN^DITMGMRG
- K DITMGMRG,DITMGMQF,DITMI
- Q
- DELETE ;
- W:'$D(DITM("NOTALK")) !,"Deleting From entry"
- I $D(DITM("SUB FILE")) D DELSUB G DELETEX
- S DIK=DITM("DIC"),DA=DITM("DIT(1)") D ^DIK K DA,DIK
- DELETEX Q
- ;
- DELSUB ;
- S DA(1)=$P(DITM("DIT(1)"),",",1),DA=$P(DITM("DIT(1)"),",",2)
- S DIK=DITM("DIC")_DA(1)_","_DITM("DSUB1")_"," D ^DIK K DA,DIK
- Q
- EOJ ;
- K DITM2,APMMD,DIC,X,Y
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITM2 2937 printed Feb 19, 2025@00:20:32 Page 2
- DITM2 ;SFISC/JCM(OHPRD)-DOES COMPARE AND MERGE ;11/18/94 15:42
- +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 ; See DITMDOC for documentation
- +8 ; Subfiles are not currently supported by the call to EN^DITM2
- +9 ; until DITC can handle them.
- +10 ;-------------------------------------------------------------------
- START ;
- EN ; Entry point
- +1 LOCK +@(DITM("DIC")_$PIECE(DITM("DIT(1)"),",",1)_")")
- +2 LOCK +@(DITM("DIC")_$PIECE(DITM("DIT(2)"),",",1)_")")
- +3 KILL DMSG,DIRUT
- +4 ; --->Sets up and calls DITC
- if '$DATA(DITM("NON-INTERACTIVE"))
- DO DITC
- +5 IF $DATA(DMSG)!($DATA(DIRUT))
- SET DITM("QFLG")=""
- GOTO END
- +6 if '$DATA(DITM("DIMERGE"))
- GOTO END
- +7 ; --->Sets up and calls DIT0
- if '$DATA(DITM("SUB FILE"))
- DO DIT0
- +8 ;---->Merges
- if $DATA(DITM("REPOINT"))&('$DATA(DITM("SUB FILE")))
- DO REPOINT
- +9 ;---------------->other files that affect patient merge
- +10 if $DATA(DITM("QFLG"))
- GOTO END
- +11 ;----->Deletes MERGED entry
- if $DATA(DITM("DELETE"))
- DO DELETE
- END LOCK -@(DITM("DIC")_$PIECE(DITM("DIT(1)"),",",1)_")")
- +1 LOCK -@(DITM("DIC")_$PIECE(DITM("DIT(2)"),",",1)_")")
- +2 ;----------->Cleanup
- DO EOJ
- +3 ;-------------->End of routine
- QUIT
- +4 ;----------------------------------------------------------------------
- DITC ;
- +1 ;***Will need to add set up for subfiles when it works******
- +2 ;
- +3 KILL DFF,DIT,DIMERGE,DDIF,DDEF,DDSP
- +4 SET DFF=DITM("DFF")
- SET DIT(1)=DITM("DIT(1)")
- SET DIT(2)=DITM("DIT(2)")
- SET DIC=DITM("DIC")
- +5 if $DATA(DITM("DIMERGE"))
- SET DIMERGE=1
- +6 if $DATA(DITM("DDIF"))
- SET DDIF=DITM("DDIF")
- +7 if $DATA(DITM("DDEF"))
- SET DDEF=DITM("DDEF")
- +8 if $DATA(DITM("DDSP"))
- SET DDSP=1
- +9 DO EN^DITC
- +10 KILL DFF,DIT,DIMERGE,DDIF,DDEF,DDSP
- +11 QUIT
- DIT0 ;
- +1 if '$DATA(DITM("NOTALK"))
- WRITE !!,"I will now merge all subfiles in this file ...",!,"This may take some time, please be patient."
- +2 KILL DA
- +3 SET (DIT("T"),DIT("F"))=DITM("DIC")
- +4 SET (D0,DA("T"))=DITM("DIT(2)")
- SET DA("F")=DITM("DIT(1)")
- +5 DO EN^DIT0
- KILL D0,DA,DIC,DIK,DIT
- +6 QUIT
- REPOINT ;
- +1 SET DITMGMQF=0
- +2 if $DATA(DITM("NON-INTERACTIVE"))
- SET DITMGMRG("NOTALK")=1
- +3 if $DATA(DITM("PACKAGE"))
- SET DITMGMRG("PACKAGE")=DITM("PACKAGE")
- +4 if '$DATA(DITM("NOTALK"))
- WRITE !!,"I will now repoint all files that point to this entry ...",!,"This may take some time, please be patient."
- +5 SET DITMGMRG("FILE")=DITM("DFF")
- SET DITMGMRG("FR")=DITM("DIT(1)")
- SET DITMGMRG("TO")=DITM("DIT(2)")
- +6 if $DATA(DITM("NOTALK"))
- SET DITMGMRG("NOTALK")=""
- +7 IF $DATA(DITM("EXCLUDE"))
- FOR DITMI=0:0
- SET DITMI=$ORDER(DITM("EXCLUDE",DITMI))
- if 'DITMI
- QUIT
- SET DITMGMRG("EXCLUDE",DITMI)=""
- +8 DO EN^DITMGMRG
- +9 KILL DITMGMRG,DITMGMQF,DITMI
- +10 QUIT
- DELETE ;
- +1 if '$DATA(DITM("NOTALK"))
- WRITE !,"Deleting From entry"
- +2 IF $DATA(DITM("SUB FILE"))
- DO DELSUB
- GOTO DELETEX
- +3 SET DIK=DITM("DIC")
- SET DA=DITM("DIT(1)")
- DO ^DIK
- KILL DA,DIK
- DELETEX QUIT
- +1 ;
- DELSUB ;
- +1 SET DA(1)=$PIECE(DITM("DIT(1)"),",",1)
- SET DA=$PIECE(DITM("DIT(1)"),",",2)
- +2 SET DIK=DITM("DIC")_DA(1)_","_DITM("DSUB1")_","
- DO ^DIK
- KILL DA,DIK
- +3 QUIT
- EOJ ;
- +1 KILL DITM2,APMMD,DIC,X,Y
- +2 QUIT