DITCPL ;MSC/GFT;COMPARE TWO LISTS, LEFT/RIGHT;24JAN2013
;;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.
;
;CALLED BY ^%, ^DITCP AND ^XPDCOM
EN(LEFT,RIGHT,HEADER) ; Main Entry Point
N WINDOW S WINDOW=30 ;HOW FAR TO LOOK AHEAD
N SHORT S SHORT=7 ;SHORTEST LINE LENGTH TO COMPARE
N DI S DI(1)=LEFT,DI(2)=RIGHT
N H S H=2
N L1,L2,E1,E2,C,S,V1,V2,X,Z,Y,I,G,J,K,L,IFN,IFE,IFP
S E1=$O(@DI(1)@(""),-1),E2=$O(@DI(2)@(""),-1) ;FIND BOTTOM OF ARRAYS TO BE COMPARED
S S="",C=IOM-2/2\1,(L1,L2)=0
D S L1=L1+1,L2=L2+1 I L1>E1!(L2>E2) D Q ;Grab two new lines. If we can't WE'RE AT END
.F I=L2:1:E2 S X=$$GET(2,I),Z=1,G=I D W2(1)
.F I=L1:1:E1 S X=$$GET(1,I),Z=1,G=I D W1
G:$$GET(1,L1)=$$GET(2,L2) D ;If lines are equal, go get two more
S V1=$$GET(1,L1),(IFE,IFP,IFN)=""
F I=L2:1:L2+WINDOW Q:I>E2 S V2=$$GET(2,I) D PARTIAL G D:IFE Q:IFN ;MOVE DOWN RIGHT SIDE TO FIND MATCH FOR 'V1'
I $$GET(1,L1+1)=$$GET(2,L2+1),$$GET(1,L1+2)=$$GET(2,L2+2)!($L($$GET(1,L1))>SHORT) D SBS(L1,L2) G D
S Z=1,G=L1,X=V1 D W1 S L2=L2-1 G D
;
GET(RL,LINE) ;RETURNS RIGHT OR LEFT LINE
I $D(@DI(RL)@(LINE))=1 Q $$STRIP(@DI(RL)@(LINE))
I $D(@DI(RL)@(LINE,0)) Q $$STRIP(@DI(RL)@(LINE,0)_$G(@DI(RL)@(LINE,"OVF",1)))
Q ""
STRIP(X) ;F Q:X'?.E1" " S X=$E(X,1,$L(X)-1) ;Take off trailing spaces
Q X
;
PARTIAL F K=1:5:26 Q:$L($E(V2,K,K+10))<SHORT I $F(V1,$E(V2,K,K+10)) S IFP=1 G E1
Q
E1 ;Go down to line I on rt side
D HEAD
F J=L2:1:I S X=$$GET(2,J) I X'?.P,$L(X)'<SHORT F Y=L1+1:1:$S(L1+WINDOW<E1:L1+WINDOW,1:E1) I $$GET(1,Y)=X S IFN=1 G Q ;Look down on the left side!
F L2=L2:1 Q:L2=I S X=$$GET(2,L2),Z=1,G=L2 D W2(1) ;Write out extras on RIGHT
S:V1=V2 IFE=1 D:'IFE SBS(L1,L2)
Q Q
;
;
SBS(L1,L2) ;SIDE BY SIDE PRINT
N S1,S2
S S1=$$GET(1,L1),S2=$$GET(2,L2),Z=1,L=0
F K=1:1 S X=$E(S1,1,C-5) S:K=1 G=L1 D W1 S Y=X,X=$E(S2,1,C-5) S:K=1 G=L2,Z=1 D W2(0) S S1=$E(S1,C-4,255),S2=$E(S2,C-4,255) D:X'=Y&$D(S)&(L=0) I $L(S1)+$L(S2)=0 S IFE=1 Q
.F L=1:1:$L(X) I $E(X,L)'=$E(Y,L) W !?L+3,"^",?L+C+4,"^" Q
Q
;
;
W1 ;WRITE LEFT SIDE, line G
D HEAD F W ! Q:'$L(X) W $S(Z:$J(G,3),1:" "),"{",$E(X,1,C-5),$C(125) S Z=0 Q:$L(X)<(C-4) S X=$E(X,C-4,999)
Q
;
W2(DITCPLLF) ;WRITE RIGHT SIDE, line G
D HEAD F W:DITCPLLF ! Q:'$L(X) W ?C+1 W $S(Z:$J(G,3),1:" "),"{",$E(X,1,C-5),$C(125) S Z=0 Q:$L(X)<(C-4) S X=$E(X,C-4,999)
Q
;
HEAD ;If we haven't written subheader, do so
S:H=2 H=0 Q:H'=0 D SUBHD^DITCP W !,?IOM-$L(HEADER)\2,HEADER S H=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITCPL 2744 printed Sep 23, 2025@20:30:20 Page 2
DITCPL ;MSC/GFT;COMPARE TWO LISTS, LEFT/RIGHT;24JAN2013
+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 ;CALLED BY ^%, ^DITCP AND ^XPDCOM
EN(LEFT,RIGHT,HEADER) ; Main Entry Point
+1 ;HOW FAR TO LOOK AHEAD
NEW WINDOW
SET WINDOW=30
+2 ;SHORTEST LINE LENGTH TO COMPARE
NEW SHORT
SET SHORT=7
+3 NEW DI
SET DI(1)=LEFT
SET DI(2)=RIGHT
+4 NEW H
SET H=2
+5 NEW L1,L2,E1,E2,C,S,V1,V2,X,Z,Y,I,G,J,K,L,IFN,IFE,IFP
+6 ;FIND BOTTOM OF ARRAYS TO BE COMPARED
SET E1=$ORDER(@DI(1)@(""),-1)
SET E2=$ORDER(@DI(2)@(""),-1)
+7 SET S=""
SET C=IOM-2/2\1
SET (L1,L2)=0
D ;Grab two new lines. If we can't WE'RE AT END
SET L1=L1+1
SET L2=L2+1
IF L1>E1!(L2>E2)
Begin DoDot:1
+1 FOR I=L2:1:E2
SET X=$$GET(2,I)
SET Z=1
SET G=I
DO W2(1)
+2 FOR I=L1:1:E1
SET X=$$GET(1,I)
SET Z=1
SET G=I
DO W1
End DoDot:1
QUIT
+3 ;If lines are equal, go get two more
if $$GET(1,L1)=$$GET(2,L2)
GOTO D
+4 SET V1=$$GET(1,L1)
SET (IFE,IFP,IFN)=""
+5 ;MOVE DOWN RIGHT SIDE TO FIND MATCH FOR 'V1'
FOR I=L2:1:L2+WINDOW
if I>E2
QUIT
SET V2=$$GET(2,I)
DO PARTIAL
if IFE
GOTO D
if IFN
QUIT
+6 IF $$GET(1,L1+1)=$$GET(2,L2+1)
IF $$GET(1,L1+2)=$$GET(2,L2+2)!($LENGTH($$GET(1,L1))>SHORT)
DO SBS(L1,L2)
GOTO D
+7 SET Z=1
SET G=L1
SET X=V1
DO W1
SET L2=L2-1
GOTO D
+8 ;
GET(RL,LINE) ;RETURNS RIGHT OR LEFT LINE
+1 IF $DATA(@DI(RL)@(LINE))=1
QUIT $$STRIP(@DI(RL)@(LINE))
+2 IF $DATA(@DI(RL)@(LINE,0))
QUIT $$STRIP(@DI(RL)@(LINE,0)_$GET(@DI(RL)@(LINE,"OVF",1)))
+3 QUIT ""
STRIP(X) ;F Q:X'?.E1" " S X=$E(X,1,$L(X)-1) ;Take off trailing spaces
+1 QUIT X
+2 ;
PARTIAL FOR K=1:5:26
if $LENGTH($EXTRACT(V2,K,K+10))<SHORT
QUIT
IF $FIND(V1,$EXTRACT(V2,K,K+10))
SET IFP=1
GOTO E1
+1 QUIT
E1 ;Go down to line I on rt side
+1 DO HEAD
+2 ;Look down on the left side!
FOR J=L2:1:I
SET X=$$GET(2,J)
IF X'?.P
IF $LENGTH(X)'<SHORT
FOR Y=L1+1:1:$SELECT(L1+WINDOW<E1:L1+WINDOW,1:E1)
IF $$GET(1,Y)=X
SET IFN=1
GOTO Q
+3 ;Write out extras on RIGHT
FOR L2=L2:1
if L2=I
QUIT
SET X=$$GET(2,L2)
SET Z=1
SET G=L2
DO W2(1)
+4 if V1=V2
SET IFE=1
if 'IFE
DO SBS(L1,L2)
Q QUIT
+1 ;
+2 ;
SBS(L1,L2) ;SIDE BY SIDE PRINT
+1 NEW S1,S2
+2 SET S1=$$GET(1,L1)
SET S2=$$GET(2,L2)
SET Z=1
SET L=0
+3 FOR K=1:1
SET X=$EXTRACT(S1,1,C-5)
if K=1
SET G=L1
DO W1
SET Y=X
SET X=$EXTRACT(S2,1,C-5)
if K=1
SET G=L2
SET Z=1
DO W2(0)
SET S1=$EXTRACT(S1,C-4,255)
SET S2=$EXTRACT(S2,C-4,255)
if X'=Y&$DATA(S)&(L=0)
Begin DoDot:1
+4 FOR L=1:1:$LENGTH(X)
IF $EXTRACT(X,L)'=$EXTRACT(Y,L)
WRITE !?L+3,"^",?L+C+4,"^"
QUIT
End DoDot:1
IF $LENGTH(S1)+$LENGTH(S2)=0
SET IFE=1
QUIT
+5 QUIT
+6 ;
+7 ;
W1 ;WRITE LEFT SIDE, line G
+1 DO HEAD
FOR
WRITE !
if '$LENGTH(X)
QUIT
WRITE $SELECT(Z:$JUSTIFY(G,3),1:" "),"{",$EXTRACT(X,1,C-5),$CHAR(125)
SET Z=0
if $LENGTH(X)<(C-4)
QUIT
SET X=$EXTRACT(X,C-4,999)
+2 QUIT
+3 ;
W2(DITCPLLF) ;WRITE RIGHT SIDE, line G
+1 DO HEAD
FOR
if DITCPLLF
WRITE !
if '$LENGTH(X)
QUIT
WRITE ?C+1
WRITE $SELECT(Z:$JUSTIFY(G,3),1:" "),"{",$EXTRACT(X,1,C-5),$CHAR(125)
SET Z=0
if $LENGTH(X)<(C-4)
QUIT
SET X=$EXTRACT(X,C-4,999)
+2 QUIT
+3 ;
HEAD ;If we haven't written subheader, do so
+1 if H=2
SET H=0
if H'=0
QUIT
DO SUBHD^DITCP
WRITE !,?IOM-$LENGTH(HEADER)\2,HEADER
SET H=1
+2 QUIT
