DID ;SFISC/XAK-LIST DD'S ;8SEP2004
;;22.0;VA FileMan;**24,105,157**;Mar 30, 1999;Build 9
;Per VHA Directive 2004-038, this routine should not be modified.
D KL,L^DICRW1 I $D(DIC) S (DUB,DIB,DFF)=+Y G O:Y'=+DIB(1),SUB
KL K DIS,DIJS,DHIT,DIB,DINM,DIDX,DIGR,DIDH,BY,DICMX,DIOEND,FLDS
K DFF,DIFF,DID,DUB,DHD,DIC,DICS,POP,DA,DR,S,F,J,K,Z,W,X,Y,M,G,N,I
K DIWF,DIPP,DPP,DIMS,DIPQ,DJ,DDL1,DDL2,DDL3,DDLF,DDN1,X1,DDRG,I1
K DIDRANGE,DIDFLD,DIDTYP
Q
;
SUB S DIC="^DD("_+Y_"," G O:$O(^DD(+Y,"SB",0))'>0 S DIC(0)="AEQZ",DIC("A")=" Select SUB-FILE: ",DIC("S")="I $P(^(0),U,2)" D ^DIC G KL:$D(DTOUT) I Y>0 S (DFF,Y)=+$P(Y(0),U,2) G SUB
G KL:X[U
O K DIC S:DFF-DUB DIC("S")="I Y-5" S DIC="^DOPT(""DID"",",DIC(0)="AEQ",DIC("B")=1 D ^DIC G KL:Y<0
O1 K DIC S DIC="^DD(DFF,"
I +Y=3 D D EN^DIP G KL
.I $D(^DIC(DFF)) S DIB(1)=$O(^DD($O(^DIC(DIB(1)))),-1)
.S DIS(0)="I $D(^DD(DFF,D0,0))",DIOEND="G L^DIDC"
.S DIOBEG="S L=0 I $G(DQI),$D(^UTILITY($J,2)) S ^(1.5)=""W $O(^DD(DIB,0,""""NM"""",0)),"""" """" W:'$D(^DIC(DIB)) """"SUB-"""" W """"FILE """""",^(2)=""X ^(1.5) ""_^(2)"
I +Y=4,'$D(DIFORMAT) D MOD^DID2 G KL:X[U
S L=0,FLDS="",BY="@.001" I +Y=5 S (FR,TO)=.01,DHIT="S F(1)=DUB",DHD="W """" D H1^DIDG",DIOEND="D T^DID" G G
I +Y=8 D G KL:DIDTYP="",KL:DIDFLD=-1,G
. S DIDTYP=$$ASKTYP Q:DIDTYP=""
. S DIDFLD=$$ASKFLD(DFF) Q:DIDFLD=-1
. S (FR,TO)=.01,DHIT="S F(1)=DFF"
. S DHD="W """" D IXHEAD1^DID"
. S DIOEND="D IX^DID"
I +Y=9 S (FR,TO)=.01,DHIT="S F(1)=DFF",DHD="W """" D KEYHEAD1^DID",DIOEND="D KEY^DID" G G
S DHIT="D ^DID1",DHD="W """" D ^DIDH",(FR,TO)="",DIOEND="D END^DID"
I +Y=6 S DHIT="D ^DIDG",DIOEND="D END^DIDG"
I +Y=2 S DHIT="D ^DIDX",DIDX=0,%=2 I '$D(DIFORMAT) D AH^DIDX G KL:%<1
I +Y=7 S DHIT="S (X1,X2)=DFF D ^DIDC",DHD="@" S DIOEND="D IOF^DID"
I "^1^2^4^"[(U_+Y_U),'$D(DIGR) D ASKRANGE(DFF,BY,.FR,.TO) G:FR=-1 KL S DIDRANGE=FR]""
G Q:DIB=0 S DIOEND(1)=DIOEND,DIOEND="D LOOP^DID" D EN1^DIP G KL
LOOP I $D(Y),Y=U Q
X DIOEND(1) I $D(M),M=U Q
I IOST?1"C-".E W $C(7) R X:DTIME I X[U!'$T Q
S DN=1,D0=0,DIB=$O(^DIC(+DIB)) Q:DIB>DIB(1)!(+DIB'=DIB) S (F(1),DUB,DFF)=DIB,DC="," D ^DIO2 I $D(M),M=U Q
G LOOP
;
END ;
I $D(^UTILITY($J,"P")) W !!!?6,"FILES POINTED TO",?44,"FIELDS",! D PTR^DIDC
D K ^UTILITY($J,"P") G IOF:DHIT["DIDX"!$G(DIDRANGE)
D IX I M=U S DN=0 Q
T ;
S S=0,M=1
T1 S S=S+1 D:$Y+3>IOSL HDR^DIDG Q:M=U
W !!,$S(S<4:$P("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):")
S DFF="^DI"_$P("E^PT^BT^ST(.403)",U,S),DA=""
F S DA=$O(@DFF@("F"_F(1),DA)) Q:DA="" D Q:M=U
. S DUB=0 F S DUB=$O(@DFF@("F"_F(1),DA,DUB)) Q:'DUB D Q:M=U
.. I $D(@DFF@(DUB,0))#2 S %1=^(0) D TEMPL
K %1 G Q:M=U,T1:S<4
IOF W:IOST'?1"C".E @IOF Q
;
TEMPL I $Y+3>IOSL D HDR^DIDG Q:M=U
W !,$P(%1,U),?30 G:DFF["DIST" FORM
S W="",Y=$P(%1,U,2) I Y D DD^%DT W Y
W ?50,"USER #"_+$P(%1,U,5),?61 I $D(@(DFF_"(DUB,""ROU"")")) W ^("ROU")_$P("*",U,DFF["DIBT")_" "
I $D(^("H")) S Y=^("H"),%=$L(Y) W:65+%>IOM ! W " ",?IOM-%-1,$E(Y,1,IOM-4)
G DES:DFF'="^DIBT"
I $D(^("DIPT")) W ?55 S Y=" '"_^("DIPT")_"' Print Template always used" W:$X+$L(Y)>IOM ! W ?IOM-$L(Y)-1,Y
I $D(^(2)) S D0=DUB,DICMX="W !?4,X" X $P(^DD(.401,1620,0),U,5,99)
F Y=1:1 Q:'$D(^DIBT(DUB,"O",Y,0)) W " " S %=^(0),D=IOM-$L(%)-5 W:$X>D !?$S(D>55:55,1:D) W %
DES N A1,%1,X S A1=$P($G(@(DFF_"(DUB,""%D"",0)")),U,3) F %1=0:0 S %1=$O(@(DFF_"(DUB,""%D"",%1)")) Q:%1'>0 Q:+A1&(%1>A1) S X=^(%1,0) W !,?5,X
Q W:DFF["DIBT" ! Q
DT G DT^DIO2
;
EN ;
Q:'$D(DIC) I 'DIC,$D(@(DIC_"0)")) S DIC=+$P(^(0),U,2)
Q:'DIC!'$D(^DIC(DIC,0,"GL")) S (DFF,DUB,DIB,DIB(1))=DIC
G O:'$D(DIFORMAT) S Y=DIFORMAT I 'Y S Y=$O(^DOPT("DID","B",Y,0))
Q:Y>9!'Y G O1
;
FORM ;
S Y=$P(%1,U,5) I Y D DD^%DT W ?30,Y
W ?50,"USER #"_+$P(%1,U,4)
;
N B,L,P
S L=1,L(1)=U
S P=0 F S P=$O(^DIST(.403,DUB,40,P)) Q:'P D Q:M=U
. Q:$D(^DIST(.403,DUB,40,P,0))[0 S B=$P(^(0),U,2) D:B BLOCK Q:M=U
. S B=0 F S B=$O(^DIST(.403,DUB,40,P,40,B)) Q:'B D BLOCK Q:M=U
S %1=0 F S %1=$O(@DFF@(DUB,15,%1)) Q:'%1 W:$D(^(%1,0))#2 !?5,^(0)
W !
Q
BLOCK ;
N I
F I=1:1:L I L(I)[(U_B_U) G BLOCKQ
S:$L(L)+$L(B)+1>245 L=L+1,L(L)=U S L(L)=L(L)_B_U
Q:$D(^DIST(.404,B,0))[0 S %1=^(0)
;
I $Y+3>IOSL D HDR^DIDG Q:M=U
W !?2,$P(%1,U) W:$P(%1,U,2)]"" ?32,"DD #"_$P(%1,U,2)
BLOCKQ Q
;
IX ;Print index details
N DIDPG,DIDFLG
S DIDPG("H")="W """" D IXHEAD^DID S:M=U PAGE(U)=1"
D WRLN^DIKCP("",0,.DIDPG) Q:M=U
I DHIT="S F(1)=DFF" D
. S DIDFLG=$S(DIDTYP="B":"",DIDTYP="T":"O",1:"FR")_$E("M",'$G(DIDFLD))
E S DIDFLG="RM"
S DIDFLG=DIDFLG_"SL2"_$E("N",$D(DINM)#2)
D PRINT^DIKCP(F(1),$G(DIDFLD),DIDFLG,.DIDPG)
Q
;
IXHEAD S DC=DC+1 I IOST?1"C".E W $C(7) R M:DTIME S:'$T M=U Q:M=U
IXHEAD1 W:$D(DIFF)&($Y) @IOF S DIFF=1
W $S("B"[$G(DIDTYP):"INDEX AND CROSS-REFERENCE",DIDTYP="T":"TRADITIONAL CROSS-REFERENCE",1:"NEW-STYLE INDEX")
W " LIST -- FILE #"_DIB_$S($G(DIDFLD):", FIELD #"_DIDFLD,1:"")
W ?(IOM-20),$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_" PAGE "_DC
S M="",$P(M,"-",IOM)="" W !,M
Q
;
KEY ;Print keys
N DIDPG
S DIDPG("H")="W """" D KEYHEAD^DID S:M=U PAGE(U)=1"
D WRLN^DIKKP("",0,.DIDPG) Q:M=U
D PRINT^DIKKP(F(1),"","ML2",.DIDPG)
Q
;
KEYHEAD S DC=DC+1 I IOST?1"C".E W $C(7) R M:DTIME S:'$T M=U Q:M=U
KEYHEAD1 W:$D(DIFF)&($Y) @IOF S DIFF=1 W "KEY LIST -- FILE #"_DIB,?(IOM-20),$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_" PAGE "_DC
S M="",$P(M,"-",IOM)="" W !,M
Q
;
ASKFLD(DIDFILE) ;Ask for a single field
Q:'$G(DIDFILE) ""
;
N %,D,D0,DA,DDD,DIC,DICR,DIX,DO,DP,DZ,X,Y,DTOUT,DUOUT
S DIC="^DD("_DIDFILE_",",DIC(0)="QAEN"
S DIC("S")="I '$P(^(0),U,2)&($P(^(0),U,2)'[""C"")"
S DIC("A")="Which field: ALL// "
D ^DIC K DIC
Q $S(X="":"",1:+Y)
;
ASKTYP() ;Ask for type of cross-reference
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SAM^T:TRADITIONAL;N:NEW;B:BOTH"
S DIR("A")="What type of cross-reference (Traditional or New)? "
S DIR("B")="Both"
S DIR("?",1)="Enter 'T' to print only traditional cross-references."
S DIR("?",2)=" Traditional cross references are stored in the data"
S DIR("?",3)=" dictionary under ^DD(file#,field#,1)."
S DIR("?",4)=" "
S DIR("?",5)="Enter 'N' to print only new-style cross-references."
S DIR("?",6)=" New-Style cross references are stored in the Index file."
S DIR("?",7)=" "
S DIR("?")="Enter 'B' to print both kinds of cross-references."
D ^DIR
Q $S($D(DIRUT):"",1:Y)
;
ASKRANGE(DIDFILE,DIDBY,DIDFR,DIDTO) ;Ask for a range of fields
Q:'$G(DIDFILE)
;
N %,D,D0,DA,DDD,DIC,DICR,DIX,DO,DP,DZ,X,Y,DTOUT,DUOUT
S DIC="^DD("_DIDFILE_",",DIC(0)="QAEN"
S DIC("A")="Start with field: FIRST// "
D ^DIC K DIC
I X="" S (DIDFR,DIDTO)="" Q
I Y=-1 S (DIDFR,DIDTO)=-1 Q
S DIDFR=$S(DIDBY[".001":+Y,1:$P(Y,U,2))
;
S DIC="^DD("_DIDFILE_",",DIC(0)="QAEN"
S DIC("A")="Go to field: "
D ^DIC K DIC
I X="" S DIDTO="" Q
I Y=-1 S (DIDFR,DIDTO)=-1 Q
S DIDTO=$S(DIDBY[".001":+Y,1:$P(Y,U,2))
;
S:DIDTO']]DIDFR %=DIDTO,DIDTO=DIDFR,DIDFR=%
Q
;
FILELST(DIDROOT) ;
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
N DIDARRAY
D EN4^DIQGDD
M @DIDROOT=DIDARRAY
Q
;
FILE(DIQGR,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
G EN2^DIQGDDF
;
FIELDLST(DIDROOT) ;
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
N DIDARRAY
D EN5^DIQGDD
M @DIDROOT=DIDARRAY
Q
;
FIELD(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
G EN1^DIQGDD
;
GET1(DIQGR,DA,DIQGPARM,DR,DIQGETA,DIQGERRA,DIQGIPAR) ;
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
G EN3^DIQGDD
;
PIECE(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;CLOSEDREF,PIECE,FLAG,ATTRIBUTE,TARGETARRAY,ERRORARRAY,INTERNAL
;PROCEDURE CALL AND * * RETURN RESULTS IN TARGET ARRAY * *
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
G EN6^DIQGDD0
DID ;SFISC/XAK-LIST DD'S ;8SEP2004
+1 ;;22.0;VA FileMan;**24,105,157**;Mar 30, 1999;Build 9
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 DO KL
DO L^DICRW1
IF $DATA(DIC)
SET (DUB,DIB,DFF)=+Y
IF Y'=+DIB(1)
GOTO O
GOTO SUB
KL KILL DIS,DIJS,DHIT,DIB,DINM,DIDX,DIGR,DIDH,BY,DICMX,DIOEND,FLDS
+1 KILL DFF,DIFF,DID,DUB,DHD,DIC,DICS,POP,DA,DR,S,F,J,K,Z,W,X,Y,M,G,N,I
+2 KILL DIWF,DIPP,DPP,DIMS,DIPQ,DJ,DDL1,DDL2,DDL3,DDLF,DDN1,X1,DDRG,I1
+3 KILL DIDRANGE,DIDFLD,DIDTYP
+4 QUIT
+5 ;
SUB SET DIC="^DD("_+Y_","
IF $ORDER(^DD(+Y,"SB",0))'>0
GOTO O
SET DIC(0)="AEQZ"
SET DIC("A")=" Select SUB-FILE: "
SET DIC("S")="I $P(^(0),U,2)"
DO ^DIC
IF $DATA(DTOUT)
GOTO KL
IF Y>0
SET (DFF,Y)=+$PIECE(Y(0),U,2)
GOTO SUB
+1 IF X[U
GOTO KL
O KILL DIC
IF DFF-DUB
SET DIC("S")="I Y-5"
SET DIC="^DOPT(""DID"","
SET DIC(0)="AEQ"
SET DIC("B")=1
DO ^DIC
IF Y<0
GOTO KL
O1 KILL DIC
SET DIC="^DD(DFF,"
+1 IF +Y=3
Begin DoDot:1
+2 IF $DATA(^DIC(DFF))
SET DIB(1)=$ORDER(^DD($ORDER(^DIC(DIB(1)))),-1)
+3 SET DIS(0)="I $D(^DD(DFF,D0,0))"
SET DIOEND="G L^DIDC"
+4 SET DIOBEG="S L=0 I $G(DQI),$D(^UTILITY($J,2)) S ^(1.5)=""W $O(^DD(DIB,0,""""NM"""",0)),"""" """" W:'$D(^DIC(DIB)) """"SUB-"""" W """"FILE """""",^(2)=""X ^(1.5) ""_^(2)"
End DoDot:1
DO EN^DIP
GOTO KL
+5 IF +Y=4
IF '$DATA(DIFORMAT)
DO MOD^DID2
IF X[U
GOTO KL
+6 SET L=0
SET FLDS=""
SET BY="@.001"
IF +Y=5
SET (FR,TO)=.01
SET DHIT="S F(1)=DUB"
SET DHD="W """" D H1^DIDG"
SET DIOEND="D T^DID"
GOTO G
+7 IF +Y=8
Begin DoDot:1
+8 SET DIDTYP=$$ASKTYP
IF DIDTYP=""
QUIT
+9 SET DIDFLD=$$ASKFLD(DFF)
IF DIDFLD=-1
QUIT
+10 SET (FR,TO)=.01
SET DHIT="S F(1)=DFF"
+11 SET DHD="W """" D IXHEAD1^DID"
+12 SET DIOEND="D IX^DID"
End DoDot:1
IF DIDTYP=""
GOTO KL
IF DIDFLD=-1
GOTO KL
GOTO G
+13 IF +Y=9
SET (FR,TO)=.01
SET DHIT="S F(1)=DFF"
SET DHD="W """" D KEYHEAD1^DID"
SET DIOEND="D KEY^DID"
GOTO G
+14 SET DHIT="D ^DID1"
SET DHD="W """" D ^DIDH"
SET (FR,TO)=""
SET DIOEND="D END^DID"
+15 IF +Y=6
SET DHIT="D ^DIDG"
SET DIOEND="D END^DIDG"
+16 IF +Y=2
SET DHIT="D ^DIDX"
SET DIDX=0
SET %=2
IF '$DATA(DIFORMAT)
DO AH^DIDX
IF %<1
GOTO KL
+17 IF +Y=7
SET DHIT="S (X1,X2)=DFF D ^DIDC"
SET DHD="@"
SET DIOEND="D IOF^DID"
+18 IF "^1^2^4^"[(U_+Y_U)
IF '$DATA(DIGR)
DO ASKRANGE(DFF,BY,.FR,.TO)
IF FR=-1
GOTO KL
SET DIDRANGE=FR]""
G IF DIB=0
QUIT
SET DIOEND(1)=DIOEND
SET DIOEND="D LOOP^DID"
DO EN1^DIP
GOTO KL
LOOP IF $DATA(Y)
IF Y=U
QUIT
+1 XECUTE DIOEND(1)
IF $DATA(M)
IF M=U
QUIT
+2 IF IOST?1"C-".E
WRITE $CHAR(7)
READ X:DTIME
IF X[U!'$TEST
QUIT
+3 SET DN=1
SET D0=0
SET DIB=$ORDER(^DIC(+DIB))
IF DIB>DIB(1)!(+DIB'=DIB)
QUIT
SET (F(1),DUB,DFF)=DIB
SET DC=","
DO ^DIO2
IF $DATA(M)
IF M=U
QUIT
+4 GOTO LOOP
+5 ;
END ;
+1 IF $DATA(^UTILITY($JOB,"P"))
WRITE !!!?6,"FILES POINTED TO",?44,"FIELDS",!
DO PTR^DIDC
D KILL ^UTILITY($JOB,"P")
IF DHIT["DIDX"!$GET(DIDRANGE)
GOTO IOF
+1 DO IX
IF M=U
SET DN=0
QUIT
T ;
+1 SET S=0
SET M=1
T1 SET S=S+1
IF $Y+3>IOSL
DO HDR^DIDG
IF M=U
QUIT
+1 WRITE !!,$SELECT(S<4:$PIECE("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):")
+2 SET DFF="^DI"_$PIECE("E^PT^BT^ST(.403)",U,S)
SET DA=""
+3 FOR
SET DA=$ORDER(@DFF@("F"_F(1),DA))
IF DA=""
QUIT
Begin DoDot:1
+4 SET DUB=0
FOR
SET DUB=$ORDER(@DFF@("F"_F(1),DA,DUB))
IF 'DUB
QUIT
Begin DoDot:2
+5 IF $DATA(@DFF@(DUB,0))#2
SET %1=^(0)
DO TEMPL
End DoDot:2
IF M=U
QUIT
End DoDot:1
IF M=U
QUIT
+6 KILL %1
IF M=U
GOTO Q
IF S<4
GOTO T1
IOF IF IOST'?1"C".E
WRITE @IOF
QUIT
+1 ;
TEMPL IF $Y+3>IOSL
DO HDR^DIDG
IF M=U
QUIT
+1 WRITE !,$PIECE(%1,U),?30
IF DFF["DIST"
GOTO FORM
+2 SET W=""
SET Y=$PIECE(%1,U,2)
IF Y
DO DD^%DT
WRITE Y
+3 WRITE ?50,"USER #"_+$PIECE(%1,U,5),?61
IF $DATA(@(DFF_"(DUB,""ROU"")"))
WRITE ^("ROU")_$PIECE("*",U,DFF["DIBT")_" "
+4 IF $DATA(^("H"))
SET Y=^("H")
SET %=$LENGTH(Y)
IF 65+%>IOM
WRITE !
WRITE " ",?IOM-%-1,$EXTRACT(Y,1,IOM-4)
+5 IF DFF'="^DIBT"
GOTO DES
+6 IF $DATA(^("DIPT"))
WRITE ?55
SET Y=" '"_^("DIPT")_"' Print Template always used"
IF $X+$LENGTH(Y)>IOM
WRITE !
WRITE ?IOM-$LENGTH(Y)-1,Y
+7 IF $DATA(^(2))
SET D0=DUB
SET DICMX="W !?4,X"
XECUTE $PIECE(^DD(.401,1620,0),U,5,99)
+8 FOR Y=1:1
IF '$DATA(^DIBT(DUB,"O",Y,0))
QUIT
WRITE " "
SET %=^(0)
SET D=IOM-$LENGTH(%)-5
IF $X>D
WRITE !?$SELECT(D>55:55,1:D)
WRITE %
DES NEW A1,%1,X
SET A1=$PIECE($GET(@(DFF_"(DUB,""%D"",0)")),U,3)
FOR %1=0:0
SET %1=$ORDER(@(DFF_"(DUB,""%D"",%1)"))
IF %1'>0
QUIT
IF +A1&(%1>A1)
QUIT
SET X=^(%1,0)
WRITE !,?5,X
Q IF DFF["DIBT"
WRITE !
QUIT
DT GOTO DT^DIO2
+1 ;
EN ;
+1 IF '$DATA(DIC)
QUIT
IF 'DIC
IF $DATA(@(DIC_"0)"))
SET DIC=+$PIECE(^(0),U,2)
+2 IF 'DIC!'$DATA(^DIC(DIC,0,"GL"))
QUIT
SET (DFF,DUB,DIB,DIB(1))=DIC
+3 IF '$DATA(DIFORMAT)
GOTO O
SET Y=DIFORMAT
IF 'Y
SET Y=$ORDER(^DOPT("DID","B",Y,0))
+4 IF Y>9!'Y
QUIT
GOTO O1
+5 ;
FORM ;
+1 SET Y=$PIECE(%1,U,5)
IF Y
DO DD^%DT
WRITE ?30,Y
+2 WRITE ?50,"USER #"_+$PIECE(%1,U,4)
+3 ;
+4 NEW B,L,P
+5 SET L=1
SET L(1)=U
+6 SET P=0
FOR
SET P=$ORDER(^DIST(.403,DUB,40,P))
IF 'P
QUIT
Begin DoDot:1
+7 IF $DATA(^DIST(.403,DUB,40,P,0))[0
QUIT
SET B=$PIECE(^(0),U,2)
IF B
DO BLOCK
IF M=U
QUIT
+8 SET B=0
FOR
SET B=$ORDER(^DIST(.403,DUB,40,P,40,B))
IF 'B
QUIT
DO BLOCK
IF M=U
QUIT
End DoDot:1
IF M=U
QUIT
+9 SET %1=0
FOR
SET %1=$ORDER(@DFF@(DUB,15,%1))
IF '%1
QUIT
IF $DATA(^(%1,0))#2
WRITE !?5,^(0)
+10 WRITE !
+11 QUIT
BLOCK ;
+1 NEW I
+2 FOR I=1:1:L
IF L(I)[(U_B_U)
GOTO BLOCKQ
+3 IF $LENGTH(L)+$LENGTH(B)+1>245
SET L=L+1
SET L(L)=U
SET L(L)=L(L)_B_U
+4 IF $DATA(^DIST(.404,B,0))[0
QUIT
SET %1=^(0)
+5 ;
+6 IF $Y+3>IOSL
DO HDR^DIDG
IF M=U
QUIT
+7 WRITE !?2,$PIECE(%1,U)
IF $PIECE(%1,U,2)]""
WRITE ?32,"DD #"_$PIECE(%1,U,2)
BLOCKQ QUIT
+1 ;
IX ;Print index details
+1 NEW DIDPG,DIDFLG
+2 SET DIDPG("H")="W """" D IXHEAD^DID S:M=U PAGE(U)=1"
+3 DO WRLN^DIKCP("",0,.DIDPG)
IF M=U
QUIT
+4 IF DHIT="S F(1)=DFF"
Begin DoDot:1
+5 SET DIDFLG=$SELECT(DIDTYP="B":"",DIDTYP="T":"O",1:"FR")_$EXTRACT("M",'$GET(DIDFLD))
End DoDot:1
+6 IF '$TEST
SET DIDFLG="RM"
+7 SET DIDFLG=DIDFLG_"SL2"_$EXTRACT("N",$DATA(DINM)#2)
+8 DO PRINT^DIKCP(F(1),$GET(DIDFLD),DIDFLG,.DIDPG)
+9 QUIT
+10 ;
IXHEAD SET DC=DC+1
IF IOST?1"C".E
WRITE $CHAR(7)
READ M:DTIME
IF '$TEST
SET M=U
IF M=U
QUIT
IXHEAD1 IF $DATA(DIFF)&($Y)
WRITE @IOF
SET DIFF=1
+1 WRITE $SELECT("B"[$GET(DIDTYP):"INDEX AND CROSS-REFERENCE",DIDTYP="T":"TRADITIONAL CROSS-REFERENCE",1:"NEW-STYLE INDEX")
+2 WRITE " LIST -- FILE #"_DIB_$SELECT($GET(DIDFLD):", FIELD #"_DIDFLD,1:"")
+3 WRITE ?(IOM-20),$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)_" PAGE "_DC
+4 SET M=""
SET $PIECE(M,"-",IOM)=""
WRITE !,M
+5 QUIT
+6 ;
KEY ;Print keys
+1 NEW DIDPG
+2 SET DIDPG("H")="W """" D KEYHEAD^DID S:M=U PAGE(U)=1"
+3 DO WRLN^DIKKP("",0,.DIDPG)
IF M=U
QUIT
+4 DO PRINT^DIKKP(F(1),"","ML2",.DIDPG)
+5 QUIT
+6 ;
KEYHEAD SET DC=DC+1
IF IOST?1"C".E
WRITE $CHAR(7)
READ M:DTIME
IF '$TEST
SET M=U
IF M=U
QUIT
KEYHEAD1 IF $DATA(DIFF)&($Y)
WRITE @IOF
SET DIFF=1
WRITE "KEY LIST -- FILE #"_DIB,?(IOM-20),$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)_" PAGE "_DC
+1 SET M=""
SET $PIECE(M,"-",IOM)=""
WRITE !,M
+2 QUIT
+3 ;
ASKFLD(DIDFILE) ;Ask for a single field
+1 IF '$GET(DIDFILE)
QUIT ""
+2 ;
+3 NEW %,D,D0,DA,DDD,DIC,DICR,DIX,DO,DP,DZ,X,Y,DTOUT,DUOUT
+4 SET DIC="^DD("_DIDFILE_","
SET DIC(0)="QAEN"
+5 SET DIC("S")="I '$P(^(0),U,2)&($P(^(0),U,2)'[""C"")"
+6 SET DIC("A")="Which field: ALL// "
+7 DO ^DIC
KILL DIC
+8 QUIT $SELECT(X="":"",1:+Y)
+9 ;
ASKTYP() ;Ask for type of cross-reference
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="SAM^T:TRADITIONAL;N:NEW;B:BOTH"
+3 SET DIR("A")="What type of cross-reference (Traditional or New)? "
+4 SET DIR("B")="Both"
+5 SET DIR("?",1)="Enter 'T' to print only traditional cross-references."
+6 SET DIR("?",2)=" Traditional cross references are stored in the data"
+7 SET DIR("?",3)=" dictionary under ^DD(file#,field#,1)."
+8 SET DIR("?",4)=" "
+9 SET DIR("?",5)="Enter 'N' to print only new-style cross-references."
+10 SET DIR("?",6)=" New-Style cross references are stored in the Index file."
+11 SET DIR("?",7)=" "
+12 SET DIR("?")="Enter 'B' to print both kinds of cross-references."
+13 DO ^DIR
+14 QUIT $SELECT($DATA(DIRUT):"",1:Y)
+15 ;
ASKRANGE(DIDFILE,DIDBY,DIDFR,DIDTO) ;Ask for a range of fields
+1 IF '$GET(DIDFILE)
QUIT
+2 ;
+3 NEW %,D,D0,DA,DDD,DIC,DICR,DIX,DO,DP,DZ,X,Y,DTOUT,DUOUT
+4 SET DIC="^DD("_DIDFILE_","
SET DIC(0)="QAEN"
+5 SET DIC("A")="Start with field: FIRST// "
+6 DO ^DIC
KILL DIC
+7 IF X=""
SET (DIDFR,DIDTO)=""
QUIT
+8 IF Y=-1
SET (DIDFR,DIDTO)=-1
QUIT
+9 SET DIDFR=$SELECT(DIDBY[".001":+Y,1:$PIECE(Y,U,2))
+10 ;
+11 SET DIC="^DD("_DIDFILE_","
SET DIC(0)="QAEN"
+12 SET DIC("A")="Go to field: "
+13 DO ^DIC
KILL DIC
+14 IF X=""
SET DIDTO=""
QUIT
+15 IF Y=-1
SET (DIDFR,DIDTO)=-1
QUIT
+16 SET DIDTO=$SELECT(DIDBY[".001":+Y,1:$PIECE(Y,U,2))
+17 ;
+18 IF DIDTO']]DIDFR
SET %=DIDTO
SET DIDTO=DIDFR
SET DIDFR=%
+19 QUIT
+20 ;
FILELST(DIDROOT) ;
+1 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+3 NEW DIDARRAY
+4 DO EN4^DIQGDD
+5 MERGE @DIDROOT=DIDARRAY
+6 QUIT
+7 ;
FILE(DIQGR,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
+1 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+3 GOTO EN2^DIQGDDF
+4 ;
FIELDLST(DIDROOT) ;
+1 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+3 NEW DIDARRAY
+4 DO EN5^DIQGDD
+5 MERGE @DIDROOT=DIDARRAY
+6 QUIT
+7 ;
FIELD(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
+1 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+3 GOTO EN1^DIQGDD
+4 ;
GET1(DIQGR,DA,DIQGPARM,DR,DIQGETA,DIQGERRA,DIQGIPAR) ;
+1 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+3 GOTO EN3^DIQGDD
+4 ;
PIECE(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;CLOSEDREF,PIECE,FLAG,ATTRIBUTE,TARGETARRAY,ERRORARRAY,INTERNAL
+1 ;PROCEDURE CALL AND * * RETURN RESULTS IN TARGET ARRAY * *
+2 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+3 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+4 GOTO EN6^DIQGDD0
