- DITC ;SFISC/XAK-MERGE OR COMPARE ENTRIES ;9/17/91 10:36 AM
- ;;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.
- ;
- START ;
- K DFF,DIT,DIMERGE,DDSP,DDIF,DDEF,DITC,DMSG
- D K2,K1,T^DICRW G:Y<0 END S (DSUB,DIT,L)=0,DSUB(L)=DIC,DITC=1
- SUB S %=$P(Y,U,2),Y=+Y D SUB^DICRW K DIA
- ENTR G:X["^"!($D(DTOUT)) 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_"-1)")) G:'% E1 S:%>0 ^(0)=U_DFF_U I %<0 W !,"NO "_DFL(DFL) S Y=-1
- G:X=U END G:Y=-1 START S DTO(DIT)=DIC_+Y_",",DTO(DIT,"X")=Y(0,0),DIT(DIT)=DIT(DIT)_+Y G:DIT=1 ENTR S DDSP=1
- Q1 S %=2 W !!,"WILL YOU WANT TO MERGE THESE ENTRIES AFTER COMPARING THEM" D YN^DICN I '% W ! S DMSG=1 D HELP^DITC0 G Q1
- S:%=1 DIMERGE=1 G:%<0 END G:'$D(DIMERGE) Q2 W ! F I=1,2 W !?5,I,?10,DTO(I,"X")
- Q15 R !!,"WHICH ENTRY SHOULD BE USED FOR DEFAULT VALUES (1 OR 2)? ",X:DTIME S:X[U DUOUT=1 S:'$T X=U,DTOUT=1 G:X["^" END I X="?" S DMSG=3 D HELP^DITC0 G Q15
- I X'=1,X'=2 W $C(7),!,"Enter '1' or '2'" G Q15
- S DDEF=X
- Q2 S %=2 W !!,"DO YOU WANT TO DISPLAY ONLY THE DISCREPANT FIELDS" D YN^DICN I '% S DMSG=2 D HELP^DITC0 G Q2
- S:%=1 DDIF=1 G:%<0 END G PRNT^DITC1
- EN ;
- D K2
- EN2 ;
- D K1 S DMSG=0 F I="DFF","DIT(1)","DIT(2)" Q:DMSG I '$D(@I) S DMSG=1,DMSG(1)=I
- G:DMSG ERREND^DITC0 F I="DFF","DIT(1)","DIT(2)" Q:DMSG I '$L(@I) S DMSG=2,DMSG(1)=I
- G:DMSG ERREND^DITC0 I '$D(^DD(DFF)) S DMSG=3,DMSG(1)=DFF G ERREND^DITC0
- S:'$D(DFL) N=$O(^DD(DFF,0,"NM",-1))_U,X1=1,M=DFF_U
- S DITC=1,K=DFF,DSUB=0
- F I=0:0 Q:'$D(^DD(K,0,"UP")) S J=^("UP"),I=$O(^DD(J,"SB",K,-1)),DSUB=DSUB+1,DSUB(DSUB)=""""_$P($P(^DD(J,I,0),U,4),";",1)_""",",K=J S:'$D(DFL) N=N_$O(^DD(K,0,"NM",-1))_U,M=M_K_U,X1=X1+1
- S DSUB=DSUB+1,DSUB(DSUB)=^DIC(K,0,"GL") I '$D(DFL) F DFL=1:1:X1 S DFL(DFL)=$P(N,U,X1-DFL+1),DFF(DFL)=$P(M,U,X1-DFL+1)
- S DMSG="" F I=1:1:2 S DTO(I)="" I DIT(I)'=0 F K=DSUB:-1:1 S DTO(I)=DTO(I)_DSUB(K)_$P(DIT(I),",",DSUB-K+1)_"," I '$L($P(DIT(I),",",DSUB-K+1)) S DMSG=4,DMSG(1)="DIT("_I_")"
- F I=1,2 I $L($P(DIT(I),",",DSUB+1,99)) S DMSG=4,DMSG(1)="DIT("_I_")"
- G:$L(DMSG) ERREND^DITC0 K DMSG G PRNT^DITC1
- K1 ;
- K %H,DSUB,DTO,DFL,DNUM
- Q
- K2 ;
- K D001,DHD,DUOUT,DTOUT,DIRUT,^UTILITY($J,"DIT"),^("DITI"),^("DITDINUM")
- Q
- END ;
- I $D(DTOUT)!($D(DUOUT)) S DIRUT=1
- D K1 K DIMERGE,DDSP,DDIF,DDEF,DIT,DFF,DDSH,DDSPC,DEQ,DIACT,X,X2,POP,DHD,D,Y,X1,^UTILITY($J,"DIT"),^("DITI"),^("DITDINUM")
- K DITC
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITC 2935 printed Feb 19, 2025@00:20:22 Page 2
- DITC ;SFISC/XAK-MERGE OR COMPARE ENTRIES ;9/17/91 10:36 AM
- +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 ;
- START ;
- +1 KILL DFF,DIT,DIMERGE,DDSP,DDIF,DDEF,DITC,DMSG
- +2 DO K2
- DO K1
- DO T^DICRW
- if Y<0
- GOTO END
- SET (DSUB,DIT,L)=0
- SET DSUB(L)=DIC
- SET DITC=1
- SUB SET %=$PIECE(Y,U,2)
- SET Y=+Y
- DO SUB^DICRW
- KILL DIA
- ENTR if X["^"!($DATA(DTOUT))
- GOTO END
- 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_"-1)"))
- if '%
- GOTO E1
- if %>0
- SET ^(0)=U_DFF_U
- IF %<0
- WRITE !,"NO "_DFL(DFL)
- SET Y=-1
- +2 if X=U
- GOTO END
- if Y=-1
- GOTO START
- 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
- Q1 SET %=2
- WRITE !!,"WILL YOU WANT TO MERGE THESE ENTRIES AFTER COMPARING THEM"
- DO YN^DICN
- IF '%
- WRITE !
- SET DMSG=1
- DO HELP^DITC0
- GOTO Q1
- +1 if %=1
- SET DIMERGE=1
- if %<0
- GOTO END
- if '$DATA(DIMERGE)
- GOTO Q2
- WRITE !
- FOR I=1,2
- WRITE !?5,I,?10,DTO(I,"X")
- Q15 READ !!,"WHICH ENTRY SHOULD BE USED FOR DEFAULT VALUES (1 OR 2)? ",X:DTIME
- if X[U
- SET DUOUT=1
- if '$TEST
- SET X=U
- SET DTOUT=1
- if X["^"
- GOTO END
- IF X="?"
- SET DMSG=3
- DO HELP^DITC0
- GOTO Q15
- +1 IF X'=1
- IF X'=2
- WRITE $CHAR(7),!,"Enter '1' or '2'"
- GOTO Q15
- +2 SET DDEF=X
- Q2 SET %=2
- WRITE !!,"DO YOU WANT TO DISPLAY ONLY THE DISCREPANT FIELDS"
- DO YN^DICN
- IF '%
- SET DMSG=2
- DO HELP^DITC0
- GOTO Q2
- +1 if %=1
- SET DDIF=1
- if %<0
- GOTO END
- GOTO PRNT^DITC1
- EN ;
- +1 DO K2
- EN2 ;
- +1 DO K1
- SET DMSG=0
- FOR I="DFF","DIT(1)","DIT(2)"
- if DMSG
- QUIT
- IF '$DATA(@I)
- SET DMSG=1
- SET DMSG(1)=I
- +2 if DMSG
- GOTO ERREND^DITC0
- FOR I="DFF","DIT(1)","DIT(2)"
- if DMSG
- QUIT
- IF '$LENGTH(@I)
- SET DMSG=2
- SET DMSG(1)=I
- +3 if DMSG
- GOTO ERREND^DITC0
- IF '$DATA(^DD(DFF))
- SET DMSG=3
- SET DMSG(1)=DFF
- GOTO ERREND^DITC0
- +4 if '$DATA(DFL)
- SET N=$ORDER(^DD(DFF,0,"NM",-1))_U
- SET X1=1
- SET M=DFF_U
- +5 SET DITC=1
- SET K=DFF
- SET DSUB=0
- +6 FOR I=0:0
- if '$DATA(^DD(K,0,"UP"))
- QUIT
- SET J=^("UP")
- SET I=$ORDER(^DD(J,"SB",K,-1))
- SET DSUB=DSUB+1
- SET DSUB(DSUB)=""""_$PIECE($PIECE(^DD(J,I,0),U,4),";",1)_""","
- SET K=J
- if '$DATA(DFL)
- SET N=N_$ORDER(^DD(K,0,"NM",-1))_U
- SET M=M_K_U
- SET X1=X1+1
- +7 SET DSUB=DSUB+1
- SET DSUB(DSUB)=^DIC(K,0,"GL")
- IF '$DATA(DFL)
- FOR DFL=1:1:X1
- SET DFL(DFL)=$PIECE(N,U,X1-DFL+1)
- SET DFF(DFL)=$PIECE(M,U,X1-DFL+1)
- +8 SET DMSG=""
- FOR I=1:1:2
- SET DTO(I)=""
- IF DIT(I)'=0
- FOR K=DSUB:-1:1
- SET DTO(I)=DTO(I)_DSUB(K)_$PIECE(DIT(I),",",DSUB-K+1)_","
- IF '$LENGTH($PIECE(DIT(I),",",DSUB-K+1))
- SET DMSG=4
- SET DMSG(1)="DIT("_I_")"
- +9 FOR I=1,2
- IF $LENGTH($PIECE(DIT(I),",",DSUB+1,99))
- SET DMSG=4
- SET DMSG(1)="DIT("_I_")"
- +10 if $LENGTH(DMSG)
- GOTO ERREND^DITC0
- KILL DMSG
- GOTO PRNT^DITC1
- K1 ;
- +1 KILL %H,DSUB,DTO,DFL,DNUM
- +2 QUIT
- K2 ;
- +1 KILL D001,DHD,DUOUT,DTOUT,DIRUT,^UTILITY($JOB,"DIT"),^("DITI"),^("DITDINUM")
- +2 QUIT
- END ;
- +1 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET DIRUT=1
- +2 DO K1
- KILL DIMERGE,DDSP,DDIF,DDEF,DIT,DFF,DDSH,DDSPC,DEQ,DIACT,X,X2,POP,DHD,D,Y,X1,^UTILITY($JOB,"DIT"),^("DITI"),^("DITDINUM")
- +3 KILL DITC
- +4 QUIT