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 Dec 13, 2024@02:54:18 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
