- 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 Feb 19, 2025@00:20:28 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
