XPDCOMF ;SFISC/GFT/MSC - COMPARE FILES ;08/14/2008
;;8.0;KERNEL;**506,539,559,713**;Jul 10, 1995;Build 15
;Per VHA Directive 2004-038, this routine should not be modified.
;DI1 & DI2 are left & right roots
;DIFLAG[1 -->compare files [2-->compare entries ["L" --> IGNORE EXTRA ENTRIES ON RIGHT SIDE
;DITCPT is array of TITLES, called by reference
EN(DI1,DI2,DIDD,DIFLAG,DITCPT) ;
N I '$D(@DI1),'$D(@DI2) Q
N I,DIR,DID,W,DIL,DIN1,DIN2,DIV1,DIV2,DIGL,DIDDN,DIO,DIV,DIT,DIOX,DITM,DIN,D1,D2
K DIRUT
S DIL=+DIFLAG
I '$D(DITCPT(1)),$G(DITCPT)'>DIL D
.I DIDD S DITCPT(1)="ENTRIES IN FILE #"_DIDD_" ("_$P($G(^DIC(DIDD,0)),U)_")"
.E S X="" D S DITCPT(1)="DATA DICTIONARY #"_$QS(DI2,1)_" ("_X_")"
..S I=$NA(@DI1,1) I '$D(@I@(0,"NM")) S I=$NA(@DI2,1)
..F S X=X_$O(@I@(0,"NM",0)) Q:'$D(@I@(0,"UP")) S X=X_" SUBFIELD" Q
;
KILL S DIV=$D(^DD(DIDD,.001)),(DIOX,U)="^",IOM=$G(IOM,80) F S X=$O(^UTILITY("DITCP",$J,DIL)) Q:$D(DIRUT)!'X K ^(X)
I '$D(@DI1) D Q
.S D1="{Missing}" I '$D(@DI2) S D2="{Also Missing}" D WB Q
.I DIL#2 S D2="" D WB Q
.S DIN2=$QS(DI2,$QL(DI2)),DIGL=0,DIN=1 D RIGHT(DI2)
I '$D(@DI2) D Q
.I DIL#2 S D1="",D2="{Missing}" D WB Q
.S DIGL=0,DIN=1,^UTILITY("DITCP",$J,"X1",DIDD,$QS(DI1,$QL(DI1)))=$P(@DI1@(0),U) G END
I 'DIDD,DIL=1 D
.N P,DITCPL F X=1,2 S Y=@("DI"_X),P=1,%="" D S P(X)=P-1
..F S %=$O(@Y@(0,"ID",%)) Q:%="" S A=$S(+%=%:%,1:+$P(%,"WDI",2)) S:$D(@Y@(A,0))=1 DITCPL(X,P)=$S(A:$P($G(@Y@(A,0)),U),1:%_" (Display only)"),P=P+1
.I DIFLAG'["L"!$D(DITCPL(1)) D DITCPL("IDENTIFIERS")
.F P="DIC","ACT" K DITCPL M DITCPL(1,1)=@DI1@(0,P),DITCPL(2,1)=@DI2@(0,P) I DIFLAG'["L"!$D(DITCPL(1)) D DITCPL($S(P="DIC":"SPECIAL LOOKUP",1:"POST-SELECTION ACTION"))
S I DIL#2 S DIN1=$O(@DI1@(0)) K ^UTILITY("DITCP",$J,DIL) G ENTRY ;WE ARE AT ROOT OF A (SUB)-FILE FIND 1ST ENTRY ON LEFT SIDE
S (DIN1,DIN2)=-1
I DIL'<DIFLAG D ;Build a header for this Entry
.N D,O S D=$G(DIDD(DIL),DIDD),O=$G(@DI2@(0)) I D-.1 S O=$P(O,U,1,D=.11+1) ;For INDEX, take FILE + NAME field
.I 'D S O="FIELD: "_O
.E S O=$O(^DD(D,0,"NM",0))_": "_$$EXT(O,.01,2) I D=.4!(D=.401)!(D=.402) S D=$P($G(@DI1@(0)),U,4) S:D O=O_" (File "_D_")"
.I DIV S O=O_" (#"_$QS(DI2,$QL(DI2))_")"
.S DITCPT(DIL)=O
G INPUT:DIDD=.402,SORT:DIDD=.401,PRINT:DIDD=.4
GET2D S DIN1=$O(@DI1@(DIN1)),DIN2=$O(@DI2@(DIN2))
;NOW CHECK IF WE'RE AT THE SAME NODE ON BOTH SIDES
NEXTD G END:$D(DIRUT) I DIN1=DIN2 G UP:DIN1="",D2:$D(@DI2@(DIN2))>9 S DIV2=@DI2@(DIN2),DIV1=@DI1@(DIN1) G GET2D:DIV2=DIV1 S DIN="",DIGL=DIN1 D G GET2D
.F S DIN=$O(^DD(DIDD,"GL",DIGL,DIN)) Q:DIN=""!$D(DIRUT) D
..I 'DIN S %X=+$E(DIN,2,9),%Y=$P(DIN,",",2),D2=$E(DIV2,%X,%Y),D1=$E(DIV1,%X,%Y)
..E S D1=$P(DIV1,U,DIN),D2=$P(DIV2,U,DIN) I DIN=2 S:DIDD=0 D1=$TR(D1,"a"),D2=$TR(D2,"a") I DIDD=.4031 D BLOCK(D1) ;SPECIFIER OR HEADER BLOCK
..I D1'=D2 D:D1]""!(DIFLAG'["L") DIO12($$TITLE) Q
.I DIGL=0,'DIDD,'$D(DIRUT) S D1=$P(DIV1,U,5,99),D2=$P(DIV2,U,5,99) Q:D1=D2 D DIO12($S($P(DIV1,U,2)["C":"COMPUTED EXPRESSION",1:"INPUT TRANSFORM")) Q
D X G END:$D(DIRUT),NEXTD
;
D2 G ENTRY:DIL#2 S Y=$O(^DD(DIDD,"GL",DIN1,0,0)) ;DOWN TO A MULTIPLE FIELD
I Y,$D(^DD(DIDD,+Y,0)) S Y=$P(^(0),U,2) I Y]"",Y-.15,$D(^DD(+Y,.01,0)) G WP:$P(^(0),U,2)["W" D DN S DIDD=+Y G S
G GET2D
;
WP S X=$P(^(0),U),%Y=0
F %X=0:0 S %X=$O(@DI1@(DIN1,%X)) Q:$D(^(+%X,0))[0 S I=^(0),%Y=$O(@DI2@(DIN2,%Y)) G WPD:$G(^(+%Y,0))'=I ;IS EVERY LINE IDENTICAL?
G GET2D:'$O(@DI2@(DIN2,%Y))
WPD D SUBHD W !?IOM-$L(X)\2,X,"..."
G GET2D
;
;^UTILITY("DITCP",$J,"X1",DIDD,DIN1) = new entry
;^UTILITY("DITCP",$J,"X2",DIDD,DIN1) = KIDS will delete
ENTRY S DIGL=0,DIN=1 G NEXTENT:'$D(@DI1@(+DIN1,0)) S X=$P(^(0),U)
;check if we are comparing to KIDS
I $E(DI1,1,12)="^XTMP(""XPDI""" D G NEXTENT:Y
.;if pointer, reset X to value stored on "^" node ;p713
.I X,$G(@DI1@(+DIN1,"^"))]"" S X=^("^")
.;check KIDS action; 0=send, 3=merge. Only these send the full record
.S Y=+$G(@DI1@(+DIN1,-1)) I Y=3!'Y S Y=0 Q
.;delete: save & goto next entry
.I Y=1 S ^UTILITY("DITCP",$J,"X2",DIDD,DIN1)=X
.Q
I DIDD=.11,$G(DITCPIF),DITCPIF-X G NEXTENT ;Skip INDEXes not for this DD
I DIDD=.4032 D D BLOCK(X) G NEXTENT
.N V S V=$$EXT(X,.01,1) I V]"" S V=$O(@($$NS(2)_"DIST(.404,""B"",V,0)")) I V S X=V
.S ^UTILITY("DITCP",$J,DIL,X)=""
S DIV=$D(^DD(DIDD,.001)) G UP:DIDD=.4032!(DIDD=19.01)!(DIDD=101.01)!(DIDD=101.0775) ;for now, give up matching BLOCKs,MENUs,ITEMs, or SUBSCRIBERS ;p713
I DIDD=.1 S DIN2=+DIN1,X=@DI1@(DIN1,0) G NEW:'$D(@DI2@(DIN2,0)),NEW:^(0)'=X,OLD ;CROSS-REFERENCE matches on entire 0 node
BIX I $P($G(@DI2@(DIN1,0)),U)=X S DIN2=DIN1 G OLD:$$MATCH,NEW:DIV
I $P(^DD(DIDD,.01,0),U,2)["P" S MSCP=$$EXT(X,.01,1) F DIN2=0:0 S DIN2=$O(@DI2@(DIN2)) G NEW:DIN2'>0 I $$EXT($P($G(^(DIN2,0)),U),2)=MSCP G OLD:$$MATCH
;if no "B" x-ref, then check entire file for match
S DIN2=0 I '$D(^DD(DIDD,0,"IX","B",DIDD,.01)) F S DIN2=$O(@DI2@(DIN2)) G NEW:DIN2'>0 I $P($G(^(DIN2,0)),U)=X G OLD:$$MATCH
BI S DIN2=$O(@DI2@("B",X,DIN2)) G NMATCH:DIN2,NEW:$L(X)<31 F S DIN2=$O(@DI2@("B",$E(X,1,30),DIN2)) G NEW:'DIN2 I $D(@DI2@(DIN2,0)),$P(^(0),X)="",$$MATCH G OLD ;p713
NMATCH I $D(@DI2@(DIN2,0)),$P(^(0),X)="" G OLD:$$MATCH ;COMPARE BY NAME
G BI
;
NEW S ^UTILITY("DITCP",$J,"X1",DIDD,DIN1)=X ;WILL SHOW EXTRA ENTRY ON LEFT SIDE
NEXTENT S DIN1=$O(@DI1@(DIN1))
N2 I DIN1 G ENTRY
I DIFLAG'["L" F DIN2=0:0 S DIN2=$O(@DI2@(DIN2)) Q:'DIN2 Q:+DIN2'=DIN2 D Q:$D(DIRUT) ;Print extras on right
.I '$D(^UTILITY("DITCP",$J,DIL,DIN2)) D RIGHT($NA(@DI2@(DIN2)))
G END:$D(DIRUT),UP
;
RIGHT(X) Q:'$D(@X@(0))#2 I DIDD=.11,$G(DITCPIF),DITCPIF-^(0) Q
D XTRAM($P(^(0),U,1,$S(DIDD=.1:99,1:1)),2) Q ;If X-REF, compare entire node
;
;DID=title, X: 1=left,2=right, P=prefix to title
XTRAM(DID,X,P) Q:DIDD=.15 ;FORGET TRIGGERED-BY
F I=DIL+(DIL#2):1 K DITCPT(I) I $O(DITCPT(I))="" Q ;S:$G(DITCPT)>(I-1) DITCPT=I-1 B:DIDD=8994 Q
I DIDD=.11 S DID="@DI"_X_"@(DIN"_X_",0)",DID=$P(@DID,U,2,3)
S DIDDN=$S(DIDD:$O(^DD(DIDD,0,"NM","")),1:"FIELD")_$S(DIV:" #"_@("DIN"_X),$D(^DIC(DIDD)):"",1:" Multiple")_": ",Y=^DD(DIDD,.01,0)
S:$G(P)]"" DIDDN=P_DIDDN
D DIT,DIO
Q
;
;
;
;
MATCH() I DIV,DIN1'=DIN2 Q 0 ;DO ENTRIES MATCH? NOT IF NUMBERS DON'T AND IT'S NUMBER-MEANINGFUL
I $D(^UTILITY("DITCP",$J,DIL,DIN2)) Q 0 ;We already matched this one
I DIDD=.11 Q '$$MISMATCH(.02) ;INDEX must match on NAME
I DIDD=.403 Q '$$MISMATCH(7) ;FORM must match on PRIMARY FILE
I DIDD=.4!(DIDD=.401)!(DIDD=.402) Q '$$MISMATCH(4) ;TEMPLATES must match on FILE
I DIDD=19 Q 1 ;OPTION matches on NAME alone
S DITM=.01
ID S DITM=$O(^DD(DIDD,0,"ID",DITM)) I DITM="" Q 1
S I=DITM S:I?1"W"1.NP I=$E(I,2,99) I $$MISMATCH(I) Q 0 ;MATCH EACH NON-NULL IDENTIFIER
G ID
;
MISMATCH(I) K B S A=$P($G(^DD(DIDD,I,0)),U,2) I A=""!(A["V") Q 0 ;DON'T TRY TO MATCH POINTERS
I A["P" S A=+$P(A,"P",2) I '$D(^DD(A,.001)) Q 0 ;p713
D Q:W="" 0 S B=W Q:'$D(^DD(DIDD,I,0)) 0 D Q:W="" 0 Q W'=B ;If two non-null values aren't equal it's a mismatch
.S A=$P(^(0),U,4),%=$P(A,";",2),W=$P(A,";"),A=$S($D(B):DI2,1:DI1) I W?." " S W="" Q
.I $D(@A@($S($D(B):DIN2,1:DIN1),W))[0 S W="" Q
.I % S W=$P(^(W),U,%)
.E S W=$E(^(W),+$E(%,2,9),$P(%,",",2))
.S:W?.E1L.E W=$$UP^DILIBF(W)
;
OLD S ^UTILITY("DITCP",$J,DIL,DIN2)="" ;Remember that we found DIN2 as a match
D DN G S
;
;
DN S DIDD(DIL)=DIDD
N X,%X F X=1,2 S %X=@("DIN"_X),(W,W(X,DIL))=@("DI"_X),W=$NA(@W@(%X)),@("DI"_X)=W ;ADD A SUBSCRIPT
S DIL=DIL+1 Q
;
UP ;
G END:'$D(W(2,DIL-1))
S DIN1=$O(@DI1) I DIL#2=0 S:$G(DITCPT)>DIL DITCPT=DIL D U G N2
D LEFT Q:$D(DIRUT) S DIN2=$O(@DI2),DIDD=DIDD(DIL-1)
D U G NEXTD
U S (DIL,Y)=DIL-1,DI1=W(1,Y),DI2=W(2,Y)
Q
;
;
2 ;
X G XTRA1:DIN2="",XTRA2:DIN1="" I +DIN1=DIN1 G XTRA1:+DIN2'=DIN2!(DIN2>DIN1),XTRA2
G XTRA2:+DIN2=DIN2!(DIN1]DIN2)
XTRA1 S X=1,DIGL=DIN1
D XTRA S DIN1=$O(@DI1@(DIN1)) Q
XTRA2 S X=2,DIGL=DIN2 D:DIFLAG'["L" XTRA S DIN2=$O(@DI2@(DIN2)) Q
;
XTRA S DIR="@DI"_X_"@(DIGL)" I $D(@DIR)<9 S DIN="",DIV=@DIR G GL
S I=$O(^(DIGL,0)) Q:'I S I=$O(^(I)),DIN=$O(^DD(DIDD,"GL",DIGL,0,0)) Q:$D(^DD(DIDD,+DIN,0))[0
S DIDDN=$P(^(0),U)_$S($P(^DD(+$P(^(0),U,2),.01,0),U,2)["W":"...",1:" Multiple"_$E("s",I>0)),(DID,DIT)="" D DIO S DIOX=0 Q
;
GL S DIN=$O(^DD(DIDD,"GL",DIGL,DIN)) Q:DIN="" S Y=$O(^(DIN,0)) G GL:'$D(^DD(DIDD,+Y,0)) S DIO=$P(^(0),U)_": "
I DIN S DID=$P(DIV,U,DIN) G:DID="" GL:$P(DIV,U,DIN,999)]"",Q
E S DID=$E(DIV,+$E(DIN,2,9),$P(DIN,",",2)) Q:DID?." "
S DIDDN=$$TITLE G GL:DIDDN="" S DIDDN=DIDDN_": "
D DIO G GL:'$D(DIRUT)
END D LEFT Q:$D(DIRUT)
I 'DIDD,DIFLAG#2 N DITCPIF,DIDD D G ENTRY ;INDEXES for File #DITCPIF
.S DITCPIF=$QS(DI1,1),DIDD=.11,DI1=$NA(@DI1,0)_"(""IX"")",DI2=$NA(@DI2,0)_"(""IX"")",(DIN1,DIN2)=0
Q Q
;
;
;
LEFT ;display left side; "X1" subscript, these are new records
N DIN1
F DIN1=0:0 S DIN1=$O(^UTILITY("DITCP",$J,"X1",DIDD,DIN1)) Q:'DIN1 D XTRAM(^(DIN1),1,"*ADD* ") K ^UTILITY("DITCP",$J,"X1",DIDD,DIN1) Q:$D(DIRUT)
;"X2" subscript, these are KIDS delete records
Q:'$D(^UTILITY("DITCP",$J,"X2",DIDD))
F DIN1=0:0 S DIN1=$O(^UTILITY("DITCP",$J,"X2",DIDD,DIN1)) Q:'DIN1 D XTRAM(^(DIN1),1,"*DELETE* ") K ^UTILITY("DITCP",$J,"X2",DIDD,DIN1) Q:$D(DIRUT)
Q
;
;
TITLE() S Y=$$FLDNUM I '$D(^DD(DIDD,+Y,0)) Q "" ;decide whether this FIELD is interesting
I $O(^(5,0)) Q "" ;Forget TRIGGERED FIELDS! (INTERESTING!)
I DIDD=.403,Y'>5 Q ""
I DIDD=19,DIGL\1=99!(Y=3.6) Q ""
I 'DIDD,Y=50!(DIGL="DT")!(DIGL=8)!(DIGL=8.5)!(DIGL=9)!(Y=1.1) Q ""
I 'DIDD,Y=.3,$G(DIV1)[":" Q "SET OF CODES" ;INSTEAD OF "POINTER"
S Y=^DD(DIDD,+Y,0) D DIT Q $P(Y,U)
;
FLDNUM() I DIN]"" Q $O(^DD(DIDD,"GL",DIGL,DIN,0))
Q .01
;
DIT ;
S DIT=$P(Y,U,2),I=$P(Y,U,3) Q
;
EXT(X,C,MSCSIDE) I X]"" N Y,Y1 I C S C=$P($G(^DD(DIDD,C,0)),U,2),Y=X,Y1=1 D:$G(MSCSIDE) D:Y1 S^DIQ I Y]"" Q Y ;101.41 BOMBED IN $$EXTERNAL^DIDU(DIDD,$$FLDNUM,,X)
.F Q:C'["P" Q:'$D(@($$NS(MSCSIDE)_$P(^(0),U,3)_"0)")) S C=$P(^(0),U,2),Y1=$D(^(+Y,0)) Q:'Y1 S Y=$P(^(0),U),C=$P($G(^DD(+C,.01,0)),U,2)
Q X
;
NS(MSCSIDE) N N S N=@("DI"_MSCSIDE) I $E(N,2)="[" Q $E(N,1,$F(N,"]")-1) ;returns "^" OR "^[NS]"
Q U
;
DIO ;X=1 MEANS LEFT SIDE, X=2 MEANS RIGHT SIDE
;DID=WHAT WE HAVE TO PRINT
S DIOX=$Y D SUBHD Q:$D(DIRUT) S DIO=DIDDN_$$EXT(DID,$$FLDNUM,X)
DIO1 ;DIO IS OUTPUT
I X=1 S DIOX(1)=DIDDN D LF
Q:$D(DIRUT)
I X=2 D:$S(DIOX-1:1,'$D(DIOX(1)):1,1:$P(DIO,DIOX(1))]"") LF Q:$D(DIRUT) W ?IOM\2 K DIOX(1)
W !,$J("",DIL),$E(DIO,1,IOM\2-DIL-1) S DIO=$E(DIO,IOM\2-DIL,999) I $L(DIO)<$S(X=1:17,X=2:2) W DIO S DIOX=X Q ;WRITE A LITTLE MORE THAN HALF A LINE
S DIOX=0 G DIO1
;
;
DIO12(T) ;WRITE D1 AND D2 SIDE BY SIDE
N D,V
Q:D1=D2!(T="")
F D=1,2 D
.S V="D"_D Q:@V=""
.S @V=T_": "_$$EXT(@V,$$FLDNUM,D)
Q:D1=D2 ;EXTERNAL VERSIONS MAY BE SAME
WB D SUBHD
F Q:D1=""&(D2="") D LF Q:$D(DIRUT) F D=1,2 S X="D"_D W:D=2 ?IOM\2 W $J("",DIL),$E(@X,1,IOM\2-DIL-1) S @X=$E(@X,IOM\2-DIL,999)
Q
;
;
SUBHD ;
N Y,L S Y=$O(DITCPT("")) Q:Y=""
I $G(DITCPT) S L=DITCPT
E S L=Y F Y=$G(DIL):-1:Y D LF G Q:$D(DIRUT)
F Q:L>$G(DIL)!$D(DIRUT) D LF Q:$D(DIRUT) W:$D(DITCPT(L)) ?IOM-$L(DITCPT(L))\2,DITCPT(L) S L=L+1
K DITCPT S DITCPT=L-1 Q ;REMEMBER HOW DEEP WE WERE AT LAST OUTPUT
;
;
LF W ! Q:$Y+3<IOSL!$D(DIRUT)
D:$E($G(IOST),1,2)="C-"
.N DIR,X,Y
.S DIR(0)="E" W ! D ^DIR S $Y=0
I '$D(DIRUT) W @IOF
Q
;
INPUT I $T(GET^DIETED)="" Q
N DITCPL F DITCPL=1,2 D GET^DIETED($NA(DITCPL(DITCPL)),@("DI"_DITCPL))
D DITCPL("EDIT FIELDS") G UP
;
SORT I $T(GET^DIBTED)="" Q
N DITCPL,DHD,DIBTA,DIBT0,MSCS F DITCPL=1,2 D
.S DIBTA=$NA(DITCPL(DITCPL))
.S DIBT0=-(DITCPL/10+$J) K ^DIBT(DIBT0) M ^DIBT(DIBT0)=@("@DI"_DITCPL),MSCS(DITCPL)=^DIBT(DIBT0,"O") ;GRAB SORT TEMPLATES INTO NEGATIVELY-NUMBERED ^DIBT NODE!
.D GET^DIBTED(DIBTA) K ^DIBT(DIBT0)
D DITCPL("SORT FIELDS")
K DITCPL M DITCPL=MSCS D DITCPL("SEARCH SPECIFICATIONS")
G UP
;
PRINT I $T(GET^DIPTED)'["," Q
N DITCPL,DISH,DHD F DITCPL=1,2 D GET^DIPTED($NA(DITCPL(DITCPL)),@("DI"_DITCPL))
D DITCPL("PRINT FIELDS") G UP
;
DITCPL(H) D EN^XPDCOML("DITCPL(1)","DITCPL(2)",H)
Q
;
BLOCK(X) N D S D=DIL+(DIL#2=0)+1 N DIL S DIL=D,DIDD(DIL)=DIDD S:$G(DITCPT)>2 DITCPT=2 D E(.404,$P($G(^DIST(.404,+X,0)),U)) ;compare ScreenMan BLOCKs
Q
E(XPDI,NAME,DIFL) N X,N,MSC,S Q:NAME=""!'XPDI
S MSCF=$G(^DIC(XPDI,0,"GL")) Q:MSCF'?1"^".E S MSCF=$E($$CREF^DILF(MSCF),2,99)
F X=1,2 S N=$$NS(X)_MSCF D S:'S S=-999 S MSC(X)=$NA(@N@(S))
.F S=0:0 S S=$O(@N@("B",NAME,S)) Q:'S Q:'$G(DIFL) Q:XPDI<.4!(XPDI>.402) Q:$P($G(@N@(S,0)),U,4)=DIFL ;TEMPLATE FILE# MUST MATCH
D EN(MSC(1),MSC(2),XPDI,$G(DIL,2),.DITCPT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDCOMF 12686 printed Apr 09, 2024@21:12:38 Page 2
XPDCOMF ;SFISC/GFT/MSC - COMPARE FILES ;08/14/2008
+1 ;;8.0;KERNEL;**506,539,559,713**;Jul 10, 1995;Build 15
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;DI1 & DI2 are left & right roots
+4 ;DIFLAG[1 -->compare files [2-->compare entries ["L" --> IGNORE EXTRA ENTRIES ON RIGHT SIDE
+5 ;DITCPT is array of TITLES, called by reference
EN(DI1,DI2,DIDD,DIFLAG,DITCPT) ;
N IF '$DATA(@DI1)
IF '$DATA(@DI2)
QUIT
+1 NEW I,DIR,DID,W,DIL,DIN1,DIN2,DIV1,DIV2,DIGL,DIDDN,DIO,DIV,DIT,DIOX,DITM,DIN,D1,D2
+2 KILL DIRUT
+3 SET DIL=+DIFLAG
+4 IF '$DATA(DITCPT(1))
IF $GET(DITCPT)'>DIL
Begin DoDot:1
+5 IF DIDD
SET DITCPT(1)="ENTRIES IN FILE #"_DIDD_" ("_$PIECE($GET(^DIC(DIDD,0)),U)_")"
+6 IF '$TEST
SET X=""
Begin DoDot:2
+7 SET I=$NAME(@DI1,1)
IF '$DATA(@I@(0,"NM"))
SET I=$NAME(@DI2,1)
+8 FOR
SET X=X_$ORDER(@I@(0,"NM",0))
if '$DATA(@I@(0,"UP"))
QUIT
SET X=X_" SUBFIELD"
QUIT
End DoDot:2
SET DITCPT(1)="DATA DICTIONARY #"_$QSUBSCRIPT(DI2,1)_" ("_X_")"
End DoDot:1
+9 ;
KILL SET DIV=$DATA(^DD(DIDD,.001))
SET (DIOX,U)="^"
SET IOM=$GET(IOM,80)
FOR
SET X=$ORDER(^UTILITY("DITCP",$JOB,DIL))
if $DATA(DIRUT)!'X
QUIT
KILL ^(X)
+1 IF '$DATA(@DI1)
Begin DoDot:1
+2 SET D1="{Missing}"
IF '$DATA(@DI2)
SET D2="{Also Missing}"
DO WB
QUIT
+3 IF DIL#2
SET D2=""
DO WB
QUIT
+4 SET DIN2=$QSUBSCRIPT(DI2,$QLENGTH(DI2))
SET DIGL=0
SET DIN=1
DO RIGHT(DI2)
End DoDot:1
QUIT
+5 IF '$DATA(@DI2)
Begin DoDot:1
+6 IF DIL#2
SET D1=""
SET D2="{Missing}"
DO WB
QUIT
+7 SET DIGL=0
SET DIN=1
SET ^UTILITY("DITCP",$JOB,"X1",DIDD,$QSUBSCRIPT(DI1,$QLENGTH(DI1)))=$PIECE(@DI1@(0),U)
GOTO END
End DoDot:1
QUIT
+8 IF 'DIDD
IF DIL=1
Begin DoDot:1
+9 NEW P,DITCPL
FOR X=1,2
SET Y=@("DI"_X)
SET P=1
SET %=""
Begin DoDot:2
+10 FOR
SET %=$ORDER(@Y@(0,"ID",%))
if %=""
QUIT
SET A=$SELECT(+%=%:%,1:+$PIECE(%,"WDI",2))
if $DATA(@Y@(A,0))=1
SET DITCPL(X,P)=$SELECT(A:$PIECE($GET(@Y@(A,0)),U),1:%_" (Display only)")
SET P=P+1
End DoDot:2
SET P(X)=P-1
+11 IF DIFLAG'["L"!$DATA(DITCPL(1))
DO DITCPL("IDENTIFIERS")
+12 FOR P="DIC","ACT"
KILL DITCPL
MERGE DITCPL(1,1)=@DI1@(0,P),DITCPL(2,1)=@DI2@(0,P)
IF DIFLAG'["L"!$DATA(DITCPL(1))
DO DITCPL($SELECT(P="DIC":"SPECIAL LOOKUP",1:"POST-SELECTION ACTION"))
End DoDot:1
S ;WE ARE AT ROOT OF A (SUB)-FILE FIND 1ST ENTRY ON LEFT SIDE
IF DIL#2
SET DIN1=$ORDER(@DI1@(0))
KILL ^UTILITY("DITCP",$JOB,DIL)
GOTO ENTRY
+1 SET (DIN1,DIN2)=-1
+2 ;Build a header for this Entry
IF DIL'<DIFLAG
Begin DoDot:1
+3 ;For INDEX, take FILE + NAME field
NEW D,O
SET D=$GET(DIDD(DIL),DIDD)
SET O=$GET(@DI2@(0))
IF D-.1
SET O=$PIECE(O,U,1,D=.11+1)
+4 IF 'D
SET O="FIELD: "_O
+5 IF '$TEST
SET O=$ORDER(^DD(D,0,"NM",0))_": "_$$EXT(O,.01,2)
IF D=.4!(D=.401)!(D=.402)
SET D=$PIECE($GET(@DI1@(0)),U,4)
if D
SET O=O_" (File "_D_")"
+6 IF DIV
SET O=O_" (#"_$QSUBSCRIPT(DI2,$QLENGTH(DI2))_")"
+7 SET DITCPT(DIL)=O
End DoDot:1
+8 if DIDD=.402
GOTO INPUT
if DIDD=.401
GOTO SORT
if DIDD=.4
GOTO PRINT
GET2D SET DIN1=$ORDER(@DI1@(DIN1))
SET DIN2=$ORDER(@DI2@(DIN2))
+1 ;NOW CHECK IF WE'RE AT THE SAME NODE ON BOTH SIDES
NEXTD if $DATA(DIRUT)
GOTO END
IF DIN1=DIN2
if DIN1=""
GOTO UP
if $DATA(@DI2@(DIN2))>9
GOTO D2
SET DIV2=@DI2@(DIN2)
SET DIV1=@DI1@(DIN1)
if DIV2=DIV1
GOTO GET2D
SET DIN=""
SET DIGL=DIN1
Begin DoDot:1
+1 FOR
SET DIN=$ORDER(^DD(DIDD,"GL",DIGL,DIN))
if DIN=""!$DATA(DIRUT)
QUIT
Begin DoDot:2
+2 IF 'DIN
SET %X=+$EXTRACT(DIN,2,9)
SET %Y=$PIECE(DIN,",",2)
SET D2=$EXTRACT(DIV2,%X,%Y)
SET D1=$EXTRACT(DIV1,%X,%Y)
+3 ;SPECIFIER OR HEADER BLOCK
IF '$TEST
SET D1=$PIECE(DIV1,U,DIN)
SET D2=$PIECE(DIV2,U,DIN)
IF DIN=2
if DIDD=0
SET D1=$TRANSLATE(D1,"a")
SET D2=$TRANSLATE(D2,"a")
IF DIDD=.4031
DO BLOCK(D1)
+4 IF D1'=D2
if D1]""!(DIFLAG'["L")
DO DIO12($$TITLE)
QUIT
End DoDot:2
+5 IF DIGL=0
IF 'DIDD
IF '$DATA(DIRUT)
SET D1=$PIECE(DIV1,U,5,99)
SET D2=$PIECE(DIV2,U,5,99)
if D1=D2
QUIT
DO DIO12($SELECT($PIECE(DIV1,U,2)["C":"COMPUTED EXPRESSION",1:"INPUT TRANSFORM"))
QUIT
End DoDot:1
GOTO GET2D
+6 DO X
if $DATA(DIRUT)
GOTO END
GOTO NEXTD
+7 ;
D2 ;DOWN TO A MULTIPLE FIELD
if DIL#2
GOTO ENTRY
SET Y=$ORDER(^DD(DIDD,"GL",DIN1,0,0))
+1 IF Y
IF $DATA(^DD(DIDD,+Y,0))
SET Y=$PIECE(^(0),U,2)
IF Y]""
IF Y-.15
IF $DATA(^DD(+Y,.01,0))
if $PIECE(^(0),U,2)["W"
GOTO WP
DO DN
SET DIDD=+Y
GOTO S
+2 GOTO GET2D
+3 ;
WP SET X=$PIECE(^(0),U)
SET %Y=0
+1 ;IS EVERY LINE IDENTICAL?
FOR %X=0:0
SET %X=$ORDER(@DI1@(DIN1,%X))
if $DATA(^(+%X,0))[0
QUIT
SET I=^(0)
SET %Y=$ORDER(@DI2@(DIN2,%Y))
if $GET(^(+%Y,0))'=I
GOTO WPD
+2 if '$ORDER(@DI2@(DIN2,%Y))
GOTO GET2D
WPD DO SUBHD
WRITE !?IOM-$LENGTH(X)\2,X,"..."
+1 GOTO GET2D
+2 ;
+3 ;^UTILITY("DITCP",$J,"X1",DIDD,DIN1) = new entry
+4 ;^UTILITY("DITCP",$J,"X2",DIDD,DIN1) = KIDS will delete
ENTRY SET DIGL=0
SET DIN=1
if '$DATA(@DI1@(+DIN1,0))
GOTO NEXTENT
SET X=$PIECE(^(0),U)
+1 ;check if we are comparing to KIDS
+2 IF $EXTRACT(DI1,1,12)="^XTMP(""XPDI"""
Begin DoDot:1
+3 ;if pointer, reset X to value stored on "^" node ;p713
+4 IF X
IF $GET(@DI1@(+DIN1,"^"))]""
SET X=^("^")
+5 ;check KIDS action; 0=send, 3=merge. Only these send the full record
+6 SET Y=+$GET(@DI1@(+DIN1,-1))
IF Y=3!'Y
SET Y=0
QUIT
+7 ;delete: save & goto next entry
+8 IF Y=1
SET ^UTILITY("DITCP",$JOB,"X2",DIDD,DIN1)=X
+9 QUIT
End DoDot:1
if Y
GOTO NEXTENT
+10 ;Skip INDEXes not for this DD
IF DIDD=.11
IF $GET(DITCPIF)
IF DITCPIF-X
GOTO NEXTENT
+11 IF DIDD=.4032
Begin DoDot:1
+12 NEW V
SET V=$$EXT(X,.01,1)
IF V]""
SET V=$ORDER(@($$NS(2)_"DIST(.404,""B"",V,0)"))
IF V
SET X=V
+13 SET ^UTILITY("DITCP",$JOB,DIL,X)=""
End DoDot:1
DO BLOCK(X)
GOTO NEXTENT
+14 ;for now, give up matching BLOCKs,MENUs,ITEMs, or SUBSCRIBERS ;p713
SET DIV=$DATA(^DD(DIDD,.001))
if DIDD=.4032!(DIDD=19.01)!(DIDD=101.01)!(DIDD=101.0775)
GOTO UP
+15 ;CROSS-REFERENCE matches on entire 0 node
IF DIDD=.1
SET DIN2=+DIN1
SET X=@DI1@(DIN1,0)
if '$DATA(@DI2@(DIN2,0))
GOTO NEW
if ^(0)'=X
GOTO NEW
GOTO OLD
BIX IF $PIECE($GET(@DI2@(DIN1,0)),U)=X
SET DIN2=DIN1
if $$MATCH
GOTO OLD
if DIV
GOTO NEW
+1 IF $PIECE(^DD(DIDD,.01,0),U,2)["P"
SET MSCP=$$EXT(X,.01,1)
FOR DIN2=0:0
SET DIN2=$ORDER(@DI2@(DIN2))
if DIN2'>0
GOTO NEW
IF $$EXT($PIECE($GET(^(DIN2,0)),U),2)=MSCP
if $$MATCH
GOTO OLD
+2 ;if no "B" x-ref, then check entire file for match
+3 SET DIN2=0
IF '$DATA(^DD(DIDD,0,"IX","B",DIDD,.01))
FOR
SET DIN2=$ORDER(@DI2@(DIN2))
if DIN2'>0
GOTO NEW
IF $PIECE($GET(^(DIN2,0)),U)=X
if $$MATCH
GOTO OLD
BI ;p713
SET DIN2=$ORDER(@DI2@("B",X,DIN2))
if DIN2
GOTO NMATCH
if $LENGTH(X)<31
GOTO NEW
FOR
SET DIN2=$ORDER(@DI2@("B",$EXTRACT(X,1,30),DIN2))
if 'DIN2
GOTO NEW
IF $DATA(@DI2@(DIN2,0))
IF $PIECE(^(0),X)=""
IF $$MATCH
GOTO OLD
NMATCH ;COMPARE BY NAME
IF $DATA(@DI2@(DIN2,0))
IF $PIECE(^(0),X)=""
if $$MATCH
GOTO OLD
+1 GOTO BI
+2 ;
NEW ;WILL SHOW EXTRA ENTRY ON LEFT SIDE
SET ^UTILITY("DITCP",$JOB,"X1",DIDD,DIN1)=X
NEXTENT SET DIN1=$ORDER(@DI1@(DIN1))
N2 IF DIN1
GOTO ENTRY
+1 ;Print extras on right
IF DIFLAG'["L"
FOR DIN2=0:0
SET DIN2=$ORDER(@DI2@(DIN2))
if 'DIN2
QUIT
if +DIN2'=DIN2
QUIT
Begin DoDot:1
+2 IF '$DATA(^UTILITY("DITCP",$JOB,DIL,DIN2))
DO RIGHT($NAME(@DI2@(DIN2)))
End DoDot:1
if $DATA(DIRUT)
QUIT
+3 if $DATA(DIRUT)
GOTO END
GOTO UP
+4 ;
RIGHT(X) if '$DATA(@X@(0))#2
QUIT
IF DIDD=.11
IF $GET(DITCPIF)
IF DITCPIF-^(0)
QUIT
+1 ;If X-REF, compare entire node
DO XTRAM($PIECE(^(0),U,1,$SELECT(DIDD=.1:99,1:1)),2)
QUIT
+2 ;
+3 ;DID=title, X: 1=left,2=right, P=prefix to title
XTRAM(DID,X,P) ;FORGET TRIGGERED-BY
if DIDD=.15
QUIT
+1 ;S:$G(DITCPT)>(I-1) DITCPT=I-1 B:DIDD=8994 Q
FOR I=DIL+(DIL#2):1
KILL DITCPT(I)
IF $ORDER(DITCPT(I))=""
QUIT
+2 IF DIDD=.11
SET DID="@DI"_X_"@(DIN"_X_",0)"
SET DID=$PIECE(@DID,U,2,3)
+3 SET DIDDN=$SELECT(DIDD:$ORDER(^DD(DIDD,0,"NM","")),1:"FIELD")_$SELECT(DIV:" #"_@("DIN"_X),$DATA(^DIC(DIDD)):"",1:" Multiple")_": "
SET Y=^DD(DIDD,.01,0)
+4 if $GET(P)]""
SET DIDDN=P_DIDDN
+5 DO DIT
DO DIO
+6 QUIT
+7 ;
+8 ;
+9 ;
+10 ;
MATCH() ;DO ENTRIES MATCH? NOT IF NUMBERS DON'T AND IT'S NUMBER-MEANINGFUL
IF DIV
IF DIN1'=DIN2
QUIT 0
+1 ;We already matched this one
IF $DATA(^UTILITY("DITCP",$JOB,DIL,DIN2))
QUIT 0
+2 ;INDEX must match on NAME
IF DIDD=.11
QUIT '$$MISMATCH(.02)
+3 ;FORM must match on PRIMARY FILE
IF DIDD=.403
QUIT '$$MISMATCH(7)
+4 ;TEMPLATES must match on FILE
IF DIDD=.4!(DIDD=.401)!(DIDD=.402)
QUIT '$$MISMATCH(4)
+5 ;OPTION matches on NAME alone
IF DIDD=19
QUIT 1
+6 SET DITM=.01
ID SET DITM=$ORDER(^DD(DIDD,0,"ID",DITM))
IF DITM=""
QUIT 1
+1 ;MATCH EACH NON-NULL IDENTIFIER
SET I=DITM
if I?1"W"1.NP
SET I=$EXTRACT(I,2,99)
IF $$MISMATCH(I)
QUIT 0
+2 GOTO ID
+3 ;
MISMATCH(I) ;DON'T TRY TO MATCH POINTERS
KILL B
SET A=$PIECE($GET(^DD(DIDD,I,0)),U,2)
IF A=""!(A["V")
QUIT 0
+1 ;p713
IF A["P"
SET A=+$PIECE(A,"P",2)
IF '$DATA(^DD(A,.001))
QUIT 0
+2 ;If two non-null values aren't equal it's a mismatch
Begin DoDot:1
+3 SET A=$PIECE(^(0),U,4)
SET %=$PIECE(A,";",2)
SET W=$PIECE(A,";")
SET A=$SELECT($DATA(B):DI2,1:DI1)
IF W?." "
SET W=""
QUIT
+4 IF $DATA(@A@($SELECT($DATA(B):DIN2,1:DIN1),W))[0
SET W=""
QUIT
+5 IF %
SET W=$PIECE(^(W),U,%)
+6 IF '$TEST
SET W=$EXTRACT(^(W),+$EXTRACT(%,2,9),$PIECE(%,",",2))
+7 if W?.E1L.E
SET W=$$UP^DILIBF(W)
End DoDot:1
if W=""
QUIT 0
SET B=W
if '$DATA(^DD(DIDD,I,0))
QUIT 0
Begin DoDot:1
End DoDot:1
if W=""
QUIT 0
QUIT W'=B
+8 ;
OLD ;Remember that we found DIN2 as a match
SET ^UTILITY("DITCP",$JOB,DIL,DIN2)=""
+1 DO DN
GOTO S
+2 ;
+3 ;
DN SET DIDD(DIL)=DIDD
+1 ;ADD A SUBSCRIPT
NEW X,%X
FOR X=1,2
SET %X=@("DIN"_X)
SET (W,W(X,DIL))=@("DI"_X)
SET W=$NAME(@W@(%X))
SET @("DI"_X)=W
+2 SET DIL=DIL+1
QUIT
+3 ;
UP ;
+1 if '$DATA(W(2,DIL-1))
GOTO END
+2 SET DIN1=$ORDER(@DI1)
IF DIL#2=0
if $GET(DITCPT)>DIL
SET DITCPT=DIL
DO U
GOTO N2
+3 DO LEFT
if $DATA(DIRUT)
QUIT
SET DIN2=$ORDER(@DI2)
SET DIDD=DIDD(DIL-1)
+4 DO U
GOTO NEXTD
U SET (DIL,Y)=DIL-1
SET DI1=W(1,Y)
SET DI2=W(2,Y)
+1 QUIT
+2 ;
+3 ;
2 ;
X if DIN2=""
GOTO XTRA1
if DIN1=""
GOTO XTRA2
IF +DIN1=DIN1
if +DIN2'=DIN2!(DIN2>DIN1)
GOTO XTRA1
GOTO XTRA2
+1 if +DIN2=DIN2!(DIN1]DIN2)
GOTO XTRA2
XTRA1 SET X=1
SET DIGL=DIN1
+1 DO XTRA
SET DIN1=$ORDER(@DI1@(DIN1))
QUIT
XTRA2 SET X=2
SET DIGL=DIN2
if DIFLAG'["L"
DO XTRA
SET DIN2=$ORDER(@DI2@(DIN2))
QUIT
+1 ;
XTRA SET DIR="@DI"_X_"@(DIGL)"
IF $DATA(@DIR)<9
SET DIN=""
SET DIV=@DIR
GOTO GL
+1 SET I=$ORDER(^(DIGL,0))
if 'I
QUIT
SET I=$ORDER(^(I))
SET DIN=$ORDER(^DD(DIDD,"GL",DIGL,0,0))
if $DATA(^DD(DIDD,+DIN,0))[0
QUIT
+2 SET DIDDN=$PIECE(^(0),U)_$SELECT($PIECE(^DD(+$PIECE(^(0),U,2),.01,0),U,2)["W":"...",1:" Multiple"_$EXTRACT("s",I>0))
SET (DID,DIT)=""
DO DIO
SET DIOX=0
QUIT
+3 ;
GL SET DIN=$ORDER(^DD(DIDD,"GL",DIGL,DIN))
if DIN=""
QUIT
SET Y=$ORDER(^(DIN,0))
if '$DATA(^DD(DIDD,+Y,0))
GOTO GL
SET DIO=$PIECE(^(0),U)_": "
+1 IF DIN
SET DID=$PIECE(DIV,U,DIN)
if DID=""
if $PIECE(DIV,U,DIN,999)]""
GOTO GL
GOTO Q
+2 IF '$TEST
SET DID=$EXTRACT(DIV,+$EXTRACT(DIN,2,9),$PIECE(DIN,",",2))
if DID?." "
QUIT
+3 SET DIDDN=$$TITLE
if DIDDN=""
GOTO GL
SET DIDDN=DIDDN_": "
+4 DO DIO
if '$DATA(DIRUT)
GOTO GL
END DO LEFT
if $DATA(DIRUT)
QUIT
+1 ;INDEXES for File #DITCPIF
IF 'DIDD
IF DIFLAG#2
NEW DITCPIF,DIDD
Begin DoDot:1
+2 SET DITCPIF=$QSUBSCRIPT(DI1,1)
SET DIDD=.11
SET DI1=$NAME(@DI1,0)_"(""IX"")"
SET DI2=$NAME(@DI2,0)_"(""IX"")"
SET (DIN1,DIN2)=0
End DoDot:1
GOTO ENTRY
Q QUIT
+1 ;
+2 ;
+3 ;
LEFT ;display left side; "X1" subscript, these are new records
+1 NEW DIN1
+2 FOR DIN1=0:0
SET DIN1=$ORDER(^UTILITY("DITCP",$JOB,"X1",DIDD,DIN1))
if 'DIN1
QUIT
DO XTRAM(^(DIN1),1,"*ADD* ")
KILL ^UTILITY("DITCP",$JOB,"X1",DIDD,DIN1)
if $DATA(DIRUT)
QUIT
+3 ;"X2" subscript, these are KIDS delete records
+4 if '$DATA(^UTILITY("DITCP",$JOB,"X2",DIDD))
QUIT
+5 FOR DIN1=0:0
SET DIN1=$ORDER(^UTILITY("DITCP",$JOB,"X2",DIDD,DIN1))
if 'DIN1
QUIT
DO XTRAM(^(DIN1),1,"*DELETE* ")
KILL ^UTILITY("DITCP",$JOB,"X2",DIDD,DIN1)
if $DATA(DIRUT)
QUIT
+6 QUIT
+7 ;
+8 ;
TITLE() ;decide whether this FIELD is interesting
SET Y=$$FLDNUM
IF '$DATA(^DD(DIDD,+Y,0))
QUIT ""
+1 ;Forget TRIGGERED FIELDS! (INTERESTING!)
IF $ORDER(^(5,0))
QUIT ""
+2 IF DIDD=.403
IF Y'>5
QUIT ""
+3 IF DIDD=19
IF DIGL\1=99!(Y=3.6)
QUIT ""
+4 IF 'DIDD
IF Y=50!(DIGL="DT")!(DIGL=8)!(DIGL=8.5)!(DIGL=9)!(Y=1.1)
QUIT ""
+5 ;INSTEAD OF "POINTER"
IF 'DIDD
IF Y=.3
IF $GET(DIV1)[":"
QUIT "SET OF CODES"
+6 SET Y=^DD(DIDD,+Y,0)
DO DIT
QUIT $PIECE(Y,U)
+7 ;
FLDNUM() IF DIN]""
QUIT $ORDER(^DD(DIDD,"GL",DIGL,DIN,0))
+1 QUIT .01
+2 ;
DIT ;
+1 SET DIT=$PIECE(Y,U,2)
SET I=$PIECE(Y,U,3)
QUIT
+2 ;
EXT(X,C,MSCSIDE) ;101.41 BOMBED IN $$EXTERNAL^DIDU(DIDD,$$FLDNUM,,X)
IF X]""
NEW Y,Y1
IF C
SET C=$PIECE($GET(^DD(DIDD,C,0)),U,2)
SET Y=X
SET Y1=1
if $GET(MSCSIDE)
Begin DoDot:1
+1 FOR
if C'["P"
QUIT
if '$DATA(@($$NS(MSCSIDE)_$PIECE(^(0),U,3)_"0)"))
QUIT
SET C=$PIECE(^(0),U,2)
SET Y1=$DATA(^(+Y,0))
if 'Y1
QUIT
SET Y=$PIECE(^(0),U)
SET C=$PIECE($GET(^DD(+C,.01,0)),U,2)
End DoDot:1
if Y1
DO S^DIQ
IF Y]""
QUIT Y
+2 QUIT X
+3 ;
NS(MSCSIDE) ;returns "^" OR "^[NS]"
NEW N
SET N=@("DI"_MSCSIDE)
IF $EXTRACT(N,2)="["
QUIT $EXTRACT(N,1,$FIND(N,"]")-1)
+1 QUIT U
+2 ;
DIO ;X=1 MEANS LEFT SIDE, X=2 MEANS RIGHT SIDE
+1 ;DID=WHAT WE HAVE TO PRINT
+2 SET DIOX=$Y
DO SUBHD
if $DATA(DIRUT)
QUIT
SET DIO=DIDDN_$$EXT(DID,$$FLDNUM,X)
DIO1 ;DIO IS OUTPUT
+1 IF X=1
SET DIOX(1)=DIDDN
DO LF
+2 if $DATA(DIRUT)
QUIT
+3 IF X=2
if $SELECT(DIOX-1
DO LF
if $DATA(DIRUT)
QUIT
WRITE ?IOM\2
KILL DIOX(1)
+4 ;WRITE A LITTLE MORE THAN HALF A LINE
WRITE !,$JUSTIFY("",DIL),$EXTRACT(DIO,1,IOM\2-DIL-1)
SET DIO=$EXTRACT(DIO,IOM\2-DIL,999)
IF $LENGTH(DIO)<$SELECT(X=1:17,X=2:2)
WRITE DIO
SET DIOX=X
QUIT
+5 SET DIOX=0
GOTO DIO1
+6 ;
+7 ;
DIO12(T) ;WRITE D1 AND D2 SIDE BY SIDE
+1 NEW D,V
+2 if D1=D2!(T="")
QUIT
+3 FOR D=1,2
Begin DoDot:1
+4 SET V="D"_D
if @V=""
QUIT
+5 SET @V=T_": "_$$EXT(@V,$$FLDNUM,D)
End DoDot:1
+6 ;EXTERNAL VERSIONS MAY BE SAME
if D1=D2
QUIT
WB DO SUBHD
+1 FOR
if D1=""&(D2="")
QUIT
DO LF
if $DATA(DIRUT)
QUIT
FOR D=1,2
SET X="D"_D
if D=2
WRITE ?IOM\2
WRITE $JUSTIFY("",DIL),$EXTRACT(@X,1,IOM\2-DIL-1)
SET @X=$EXTRACT(@X,IOM\2-DIL,999)
+2 QUIT
+3 ;
+4 ;
SUBHD ;
+1 NEW Y,L
SET Y=$ORDER(DITCPT(""))
if Y=""
QUIT
+2 IF $GET(DITCPT)
SET L=DITCPT
+3 IF '$TEST
SET L=Y
FOR Y=$GET(DIL):-1:Y
DO LF
if $DATA(DIRUT)
GOTO Q
+4 FOR
if L>$GET(DIL)!$DATA(DIRUT)
QUIT
DO LF
if $DATA(DIRUT)
QUIT
if $DATA(DITCPT(L))
WRITE ?IOM-$LENGTH(DITCPT(L))\2,DITCPT(L)
SET L=L+1
+5 ;REMEMBER HOW DEEP WE WERE AT LAST OUTPUT
KILL DITCPT
SET DITCPT=L-1
QUIT
+6 ;
+7 ;
LF WRITE !
if $Y+3<IOSL!$DATA(DIRUT)
QUIT
+1 if $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:1
+2 NEW DIR,X,Y
+3 SET DIR(0)="E"
WRITE !
DO ^DIR
SET $Y=0
End DoDot:1
+4 IF '$DATA(DIRUT)
WRITE @IOF
+5 QUIT
+6 ;
INPUT IF $TEXT(GET^DIETED)=""
QUIT
+1 NEW DITCPL
FOR DITCPL=1,2
DO GET^DIETED($NAME(DITCPL(DITCPL)),@("DI"_DITCPL))
+2 DO DITCPL("EDIT FIELDS")
GOTO UP
+3 ;
SORT IF $TEXT(GET^DIBTED)=""
QUIT
+1 NEW DITCPL,DHD,DIBTA,DIBT0,MSCS
FOR DITCPL=1,2
Begin DoDot:1
+2 SET DIBTA=$NAME(DITCPL(DITCPL))
+3 ;GRAB SORT TEMPLATES INTO NEGATIVELY-NUMBERED ^DIBT NODE!
SET DIBT0=-(DITCPL/10+$JOB)
KILL ^DIBT(DIBT0)
MERGE ^DIBT(DIBT0)=@("@DI"_DITCPL),MSCS(DITCPL)=^DIBT(DIBT0,"O")
+4 DO GET^DIBTED(DIBTA)
KILL ^DIBT(DIBT0)
End DoDot:1
+5 DO DITCPL("SORT FIELDS")
+6 KILL DITCPL
MERGE DITCPL=MSCS
DO DITCPL("SEARCH SPECIFICATIONS")
+7 GOTO UP
+8 ;
PRINT IF $TEXT(GET^DIPTED)'[","
QUIT
+1 NEW DITCPL,DISH,DHD
FOR DITCPL=1,2
DO GET^DIPTED($NAME(DITCPL(DITCPL)),@("DI"_DITCPL))
+2 DO DITCPL("PRINT FIELDS")
GOTO UP
+3 ;
DITCPL(H) DO EN^XPDCOML("DITCPL(1)","DITCPL(2)",H)
+1 QUIT
+2 ;
BLOCK(X) ;compare ScreenMan BLOCKs
NEW D
SET D=DIL+(DIL#2=0)+1
NEW DIL
SET DIL=D
SET DIDD(DIL)=DIDD
if $GET(DITCPT)>2
SET DITCPT=2
DO E(.404,$PIECE($GET(^DIST(.404,+X,0)),U))
+1 QUIT
E(XPDI,NAME,DIFL) NEW X,N,MSC,S
if NAME=""!'XPDI
QUIT
+1 SET MSCF=$GET(^DIC(XPDI,0,"GL"))
if MSCF'?1"^".E
QUIT
SET MSCF=$EXTRACT($$CREF^DILF(MSCF),2,99)
+2 FOR X=1,2
SET N=$$NS(X)_MSCF
Begin DoDot:1
+3 ;TEMPLATE FILE# MUST MATCH
FOR S=0:0
SET S=$ORDER(@N@("B",NAME,S))
if 'S
QUIT
if '$GET(DIFL)
QUIT
if XPDI<.4!(XPDI>.402)
QUIT
if $PIECE($GET(@N@(S,0)),U,4)=DIFL
QUIT
End DoDot:1
if 'S
SET S=-999
SET MSC(X)=$NAME(@N@(S))
+4 DO EN(MSC(1),MSC(2),XPDI,$GET(DIL,2),.DITCPT)
+5 QUIT
