DITM2.m

DITM2 ;SFISC/JCM(OHPRD)-DOES COMPARE AND MERGE ;11/18/94  15:42

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 ; 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

DITM2     ;SFISC/JCM(OHPRD)-DOES COMPARE AND MERGE ;11/18/94  15:42

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ; See DITMDOC for documentation

 +5       ; Subfiles are not currently supported by the call to EN^DITM2

 +6       ; until DITC can handle them.

 +7       ;-------------------------------------------------------------------

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