Annotation of freem_fileman/DID.m, revision 1.1.1.1
1.1 snw 1: DID ;SFISC/XAK-LIST DD'S ;10:11 AM 16 Dec 1994
2: ;;21.0;VA FileMan;;Dec 28, 1994
3: ;Per VHA Directive 10-93-142, this routine should not be modified.
4: D KL,L^DICRW1 I $D(DIC) S (DUB,DIB,DFF)=+Y G O:Y'=+DIB(1),SUB
5: KL K DIS,DIJS,DHIT,DIB,DINM,DIDX,DIGR,DIDH,BY,DICMX,DIOEND,FLDS
6: K DFF,DIFF,DID,DUB,DHD,DIC,DICS,POP,DA,DR,S,F,J,K,Z,W,X,Y,M,G,N,I
7: K DIWF,DIPP,DPP,DIMS,DIPQ,DJ,DDL1,DDL2,DDL3,DDLF,DDN1,X1,DDRG,I1 Q
8: ;
9: 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
10: G KL:X[U
11: 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
12: O1 K DIC S DIC="^DD(DFF,"
13: I +Y=3 S DIS(0)="I $D(^DD(DFF,D0,0))",DIOEND="G L^DIDC",DIOBEG="S L=0 I $D(DQI),DQI,$D(^UTILITY($J,2)) S ^(1.5)=""W $O(^DD(DIB,0,""""NM"""",0))_"""" FILE """""",^(2)=""X ^(1.5) ""_^(2)" D EN^DIP G KL
14: I +Y=4,'$D(DIFORMAT) D MOD^DID2 G KL:X[U
15: 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
16: S DHIT="D ^DID1",DHD="W """" D ^DIDH",(FR,TO)="",DIOEND="D END^DID"
17: I +Y=6 S DHIT="D ^DIDG",DIOEND="D END^DIDG"
18: I +Y=2 S DHIT="D ^DIDX",DIDX=0,%=2 I '$D(DIFORMAT) D AH^DIDX Q:%<1
19: I +Y=7 S DHIT="S (X1,X2)=DFF D ^DIDC",DHD="@" S DIOEND="D IOF^DID"
20: G Q:DIB=0 S DIOEND(1)=DIOEND,DIOEND="D LOOP^DID" D EN1^DIP G KL
21: LOOP I $D(Y),Y=U Q
22: X DIOEND(1) I $D(M),M=U Q
23: I IOST?1"C-".E W $C(7) R X:DTIME I X[U!'$T Q
24: 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
25: G LOOP
26: ;
27: END ;
28: I $D(^UTILITY($J,"P")) W !!!?6,"FILES POINTED TO",?44,"FIELDS",! D PTR^DIDC
29: D K ^UTILITY($J,"P") G IOF:DHIT["DIDX"
30: T ;
31: S S=0,M=1
32: T1 S S=S+1 D:$Y+3>IOSL HDR^DIDG Q:M=U
33: W !!,$S(S<4:$P("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):")
34: S DFF="^DI"_$P("E^PT^BT^ST(.403)",U,S),DA=""
35: F S DA=$O(@DFF@("F"_F(1),DA)) Q:DA="" D Q:M=U
36: . S DUB=0 F S DUB=$O(@DFF@("F"_F(1),DA,DUB)) Q:'DUB D Q:M=U
37: .. I $D(@DFF@(DUB,0))#2 S %1=^(0) D TEMPL
38: K %1 G Q:M=U,T1:S<4
39: IOF W:IOST'?1"C".E @IOF Q
40: ;
41: TEMPL I $Y+3>IOSL D HDR^DIDG Q:M=U
42: W !,$P(%1,U),?30 G:DFF["DIST" FORM
43: S W="",Y=$P(%1,U,2) I Y D DD^%DT W Y
44: W ?50,"USER #"_+$P(%1,U,5),?61 I $D(@(DFF_"(DUB,""ROU"")")) W ^("ROU")_$P("*",U,DFF["DIBT")_" "
45: I $D(^("H")) S Y=^("H"),%=$L(Y) W:65+%>IOM ! W " ",?IOM-%-1,$E(Y,1,IOM-4)
46: G DES:DFF'="^DIBT"
47: I $D(^("DIPT")) W ?55 S Y=" '"_^("DIPT")_"' Print Template always used" W:$X+$L(Y)>IOM ! W ?IOM-$L(Y)-1,Y
48: I $D(^(2)) S D0=DUB,DICMX="W !?4,X" X $P(^DD(.401,1620,0),U,5,99)
49: 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 %
50: 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
51: Q W:DFF["DIBT" ! Q
52: DT G DT^DIO2
53: ;
54: EN ;
55: Q:'$D(DIC) I 'DIC,$D(@(DIC_"0)")) S DIC=+$P(^(0),U,2)
56: Q:'DIC!'$D(^DIC(DIC,0,"GL")) S (DFF,DUB,DIB,DIB(1))=DIC
57: G O:'$D(DIFORMAT) S Y=DIFORMAT I 'Y S Y=$O(^DOPT("DID","B",Y,0))
58: Q:Y>7!'Y G O1
59: ;
60: FORM ;
61: S Y=$P(%1,U,5) I Y D DD^%DT W ?30,Y
62: W ?50,"USER #"_+$P(%1,U,4)
63: ;
64: N B,L,P
65: S L=1,L(1)=U
66: S P=0 F S P=$O(^DIST(.403,DUB,40,P)) Q:'P D Q:M=U
67: . Q:$D(^DIST(.403,DUB,40,P,0))[0 S B=$P(^(0),U,2) D:B BLOCK Q:M=U
68: . S B=0 F S B=$O(^DIST(.403,DUB,40,P,40,B)) Q:'B D BLOCK Q:M=U
69: S %1=0 F S %1=$O(@DFF@(DUB,15,%1)) Q:'%1 W:$D(^(%1,0))#2 !?5,^(0)
70: W !
71: Q
72: BLOCK ;
73: N I
74: F I=1:1:L I L(I)[(U_B_U) G BLOCKQ
75: S:$L(L)+$L(B)+1>245 L=L+1,L(L)=U S L(L)=L(L)_B_U
76: Q:$D(^DIST(.404,B,0))[0 S %1=^(0)
77: ;
78: I $Y+3>IOSL D HDR^DIDG Q:M=U
79: W !?2,$P(%1,U) W:$P(%1,U,2)]"" ?32,"DD #"_$P(%1,U,2)
80: BLOCKQ Q
81: ;
82: FILELST(DIDROOT) ;
83: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
84: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
85: N DIDARRAY
86: D EN4^DIQGDD
87: M @DIDROOT=DIDARRAY
88: Q
89: ;
90: FILE(DIQGR,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
91: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
92: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
93: G EN2^DIQGDD
94: ;
95: FIELDLST(DIDROOT) ;
96: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
97: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
98: N DIDARRAY
99: D EN5^DIQGDD
100: M @DIDROOT=DIDARRAY
101: Q
102: ;
103: FIELD(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
104: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
105: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
106: G EN1^DIQGDD
107: ;
108: GET1(DIQGR,DA,DIQGPARM,DR,DIQGETA,DIQGERRA,DIQGIPAR) ;
109: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
110: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
111: G EN3^DIQGDD
112: ;
113: PIECE(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;CLOSEDREF,PIECE,FLAG,ATTRIBUTE,TARGETARRAY,ERRORARRAY,INTERNAL
114: ;PROCEDURE CALL AND * * RETURN RESULTS IN TARGET ARRAY * *
115: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
116: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
117: G EN6^DIQGDD0
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DID.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman