DITM1.m

DITM1 ;SFISC/JCM(OHPRD)-ASKS SUBFILE FOR COMPARE AND MERGE ;2/24/93  14:00

 ;;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.

 ;

 ; When subfiles work will need to delete SUB+0 and uncomment SUB+1

 ;--------------------------------------------------------------------

START ;

SUB S L=L+1,DFL(L)=$O(^DD(+Y,0,"NM","")),(DFF,DFF(L))=+Y

 ;S %=$P(Y,U,2),Y=+Y D SUB^DICRW K DIA S:Y>0 DITM("SUBFILE")=+Y

ENTR I $D(DTOUT)!(X["^") S DITM("QFLG")="" G END

 K DIC S DIC(0)="AEQMZ",DIC=DSUB(0),DFL=1,DIT=DIT+1,DIT(DIT)="" W:DIT=1 !

E1 S DIC("A")=$E("        ",1,DFL-1*3)_$S(DIT=2:"   WITH ",1:"COMPARE ")_DFL(DFL)_": " I (DIT=2),(DFL=L),($P(DIT(1),",",1,L-1)=$P(DIT(2),",",1,L-1)) S DIC("S")="I Y-"_$P(DIT(1),",",L)

 D ^DIC K DIC("S"),DIC("A") I Y>0,$D(DSUB(DFL)),$D(DFL(DFL+1)) S DIC=DIC_+Y_","_DSUB(DFL),DIT(DIT)=DIT(DIT)_+Y_",",DFL=DFL+1 S %=$O(@(DIC_""""")")) G:%'=""&'% E1 S:%>0 ^(0)=U_DFF_U I %="" W !,"NO "_DFL(DFL) S (%,Y)=-1

 S:X=U DITM("QFLG")="" G:X=U!(Y=-1) END S DTO(DIT)=DIC_+Y_",",DTO(DIT,"X")=Y(0,0),DIT(DIT)=DIT(DIT)_+Y G:DIT=1 ENTR S DDSP=1

 S DITM("DFF")=DFF,DITM("DIT(1)")=DIT(1),DITM("DIT(2)")=DIT(2)

 S DITM("DIC")=DSUB(0)

 I $D(DITM("SUB FILE")),$D(DSUB(1)) S DITM("DSUB1")=$P(DSUB(1),",",1)

END ;

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DITM1   1484     printed  Feb 19, 2025@00:20:31                                                                                                                                                                                                       Page 2

DITM1     ;SFISC/JCM(OHPRD)-ASKS SUBFILE FOR COMPARE AND MERGE ;2/24/93  14:00

 +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       ; When subfiles work will need to delete SUB+0 and uncomment SUB+1

 +8       ;--------------------------------------------------------------------

START     ;

SUB        SET L=L+1

           SET DFL(L)=$ORDER(^DD(+Y,0,"NM",""))

           SET (DFF,DFF(L))=+Y

 +1       ;S %=$P(Y,U,2),Y=+Y D SUB^DICRW K DIA S:Y>0 DITM("SUBFILE")=+Y

ENTR       IF $DATA(DTOUT)!(X["^")

               SET DITM("QFLG")=""

               GOTO END

 +1        KILL DIC

           SET DIC(0)="AEQMZ"

           SET DIC=DSUB(0)

           SET DFL=1

           SET DIT=DIT+1

           SET DIT(DIT)=""

           if DIT=1

               WRITE !

E1         SET DIC("A")=$EXTRACT("        ",1,DFL-1*3)_$SELECT(DIT=2:"   WITH ",1:"COMPARE ")_DFL(DFL)_": "

           IF (DIT=2)

               IF (DFL=L)

                   IF ($PIECE(DIT(1),",",1,L-1)=$PIECE(DIT(2),",",1,L-1))

                       SET DIC("S")="I Y-"_$PIECE(DIT(1),",",L)

 +1        DO ^DIC

           KILL DIC("S"),DIC("A")

           IF Y>0

               IF $DATA(DSUB(DFL))

                   IF $DATA(DFL(DFL+1))

                       SET DIC=DIC_+Y_","_DSUB(DFL)

                       SET DIT(DIT)=DIT(DIT)_+Y_","

                       SET DFL=DFL+1

                       SET %=$ORDER(@(DIC_""""")"))

                       if %'=""&'%

                           GOTO E1

                       if %>0

                           SET ^(0)=U_DFF_U

                       IF %=""

                           WRITE !,"NO "_DFL(DFL)

                           SET (%,Y)=-1

 +2        if X=U

               SET DITM("QFLG")=""

           if X=U!(Y=-1)

               GOTO END

           SET DTO(DIT)=DIC_+Y_","

           SET DTO(DIT,"X")=Y(0,0)

           SET DIT(DIT)=DIT(DIT)_+Y

           if DIT=1

               GOTO ENTR

           SET DDSP=1

 +3        SET DITM("DFF")=DFF

           SET DITM("DIT(1)")=DIT(1)

           SET DITM("DIT(2)")=DIT(2)

 +4        SET DITM("DIC")=DSUB(0)

 +5        IF $DATA(DITM("SUB FILE"))

               IF $DATA(DSUB(1))

                   SET DITM("DSUB1")=$PIECE(DSUB(1),",",1)

END       ;

 +1        QUIT