Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DID

DID.m

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