210 lines
7.7 KiB
Mathematica
210 lines
7.7 KiB
Mathematica
DID ;SFISC/XAK-LIST DD'S ;2:19 PM 5 Mar 2002
|
|
;;22.0;VA FileMan;**24,105**;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, 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:DIDTYP=""!(DIDFLD=-1) KL G 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
|