source: cprs/branches/tmg-cprs/m_files/TMGDIS1.m@ 1716

Last change on this file since 1716 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload

File size: 4.8 KB
Line 
1TMGDIS1 ;TMG/kst/Custom version of DIS1 ;03/25/06 ; 5/15/10 11:15pm
2 ;;1.0;TMG-LIB;**1**;01/01/06
3 ;----Prior header below ----------
4 ;SFISC/GFT-BUILD DIS-ARRAY ;20MAR2005
5 ;;22.0;VA FileMan;**6,77,97,113,144**;Mar 30, 1999;Build 5
6 ;
7DIS1 ;"Purpose: BUILD DIS-ARRAY
8 KILL DIS0
9 IF $D(DL)#2 SET DIS0=DL
10 SET DL(0)=""
11 ;"W !
12 IF $D(DE)>1!$D(DJ) GOTO 1
13 IF DL=1 DO
14 . SET DL(0)=DL(1),DL=0 KILL DL(1)
15 ELSE DO
16 . FOR P=2:1 SET Y=$P(DL(1),U,P) QUIT:Y="" DO
17 . . SET Y=U_Y_U
18 . . SET X=2
19 . . DO 2
20 FOR X=1:1 QUIT:'$D(DL(X)) DO
21 . FOR Y=X+1:1 QUIT:'$D(DL(Y)) DO
22 . . IF DL(X)=DL(Y)!(DL(Y)?.P) DO
23 . . . SET DL=DL-1
24 . . . KILL DL(Y)
25 . . . FOR P=Y:1:DL SET DL(P)=DL(P+1) KILL DL(P+1)
261 DO ENT
27 IF '$D(DIAR) DO DIS2^TMGDIS2 GOTO TMGDONE ;"Sets TMGRESULT
28 DO DIS^TMGDIS2 ;"Sets TMGRESULT
29 GOTO TMGDONE ;"quit from there
30 ;
31ENT SET DK(0)=DK,Z="D0,"
32 FOR DQ=0:1:DL DO
33 . KILL R,M
34 . DO
35 . . N I SET I=""
36 . . FOR SET I=$O(DI(I)) QUIT:'I KILL DI(I)
37 . . QUIT
38 . SET X=0,DQ(0)=DQ,R=-1
39 . DO MAKE
40 . SET %=0
41 . FOR SET R=$O(R(R)) QUIT:R="" DO
42 . . IF R(R)<2 SET DIS(R)=DIS(R)_" K D"
43 SET R=-1
44 QUIT
45 ;
46 ;"----------------------------------------
472 IF X'>DL QUIT:DL(X)'[Y SET X=X+1 GOTO 2
48 SET DL(0)=U_$P(Y,U,2)_DL(0)
49 SET P=P-1
5022 SET X=X-1
51 SET DQ=$F(DL(X),Y)
52 SET DL(X)=$E(DL(X),1,DQ-$L(Y))_$E(DL(X),DQ,999)
53 GOTO 22:X>1
54 QUIT
55 ;
56 ;"----------------------------------------
57C SET Y=Y_$S(DV="'":" I 'X",1:" I "_$$XFORM("X")_DV)
58 DO SD
59MAKE SET DC=DI
60 SET DQ=+DQ
61 SET X=X+1
62 SET Y=$P(DL(DQ),U,X+1)
63 QUIT:Y=""
64 SET S=+Y
65 SET DN=$E("'",Y["'")
66 SET Y=DC(S),D=0,DL=0
67 IF $D(DJ(DQ,S)) DO
68 . SET D=$P(DJ(DQ,S),U,2),DL=+DJ(DQ,S)
69 . IF $D(DI(DL)) SET DC=DI(DL)
70 SET DQ=DQ(DL)
71 SET Z=$P(Z,",",1,D+D+1)_","
72 SET DU=$P($P(Y,U),",",DL+1,99)
73 SET O=DK(DL)
74 SET DV=DN_$P(Y,U,2)
75 IF DV?1"''".E SET DV=$E(DV,3,999)
76LEV SET DL=DL+1
77 SET DN=$S($D(DE(+DQ,X,DL)):DE(+DQ,X,DL),1:1)
78 SET:$G(DI(DL-1))]"" DI(DL)=DI(DL-1)
79 IF DU<0,$D(DY(-DU)) GOTO X
80 IF DU<0 SET Y=DA(-DU) GOTO C
81 SET N=$P(^DD(O,+DU,0),U,4)
82 SET DE=$P(N,";",1)
83 SET Y=$P(N,";",2)
84 IF Y="" SET Y="D"_D GOTO M
85 IF $P(^(0),U,2)["C" SET Y=$P(^(0),U,5,99) GOTO C
86 SET:+DE'=DE DE=""""_DE_""""
87 SET Z=Z_DE
88 SET E="$G("_DC_Z_"))"
89 IF Y SET Y="$P("_E_",U,"_Y_")" GOTO M
90 IF Y'=0 SET Y=$E(Y,2,99) SET:$P(Y,",",2)=+Y Y=+Y SET Y="$E("_E_","_Y_")" GOTO M
91 FOR Y=65:1 SET M=DQ_$C(Y) QUIT:'$D(DIS(M))
92 SET D=D+1
93 SET Y="S D"_D_"=+$O("_DC_Z_",0)) X DIS("""_M_""") I $T"
94 DO SD
95 IF $D(DIAR) SET DIAR(DIARF,DQ)="X DIS("""_M_"A"")"
96 SET DQ=M
97 SET DIS(DQ)="F X DIS("""_DQ_"A"") X:D"_D_"'>0 ""IF "_(DN=3)_""" Q:"_$E("'",DN>1)_"$T S D"_D_"=$O("_DC_Z_",D"_D_")) Q:D"_D_"'>0"
98WP SET DQ=DQ_"A"
99 SET DQ(DL)=DQ
100 IF DU'["," SET DIS(DQ)="I "_$$XFORM("$G(^(D"_D_",0))")_DV GOTO MAKE
101 SET O=+$P(^(0),U,2),DK(DL)=O,Z=Z_",D"_D_","
102N SET DU=$P(DU,",",2,99)
103 GOTO LEV
104 ;
105M DO SET Y=Y_DV DO SD GOTO MAKE
106VARPOINT .IF $P(^DD(O,+DU,0),U,2)["V" SET Y="I "_$$XFORM("$$EXTERNAL^DIDU("_O_","_+DU_","""","_Y_")") QUIT
107OUTX .IF $D(^(2)),$P(^(0),U,2)'["D",DV'["=" SET M=0,Y="S Y="_Y_" "_$$OVFL(^(2))_" I "_$$XFORM("Y") QUIT ;**GFT 144
108SET .IF $D(DIS(U,S)) SET Y="S Y="_Y_" I $S(Y="""":"""",$D(DIS(U,"_S_",Y)):DIS(U,"_S_",Y),1:"""")" QUIT
109 .SET M=Y,Y="I "_$$XFORM(Y)
110 ;
111XFORM(Y) IF '$D(DIS("XFORM",S)) QUIT Y
112 QUIT $P(DIS("XFORM",S),";")_Y_$P(DIS("XFORM",S),";",2)
113 ;
114SD IF $D(R(DQ)),R(DQ)>1 SET Y="K D "_Y_" S:$T D=1"
115 IF '$D(DIS(DQ)) SET DIS(DQ)=Y QUIT
116 IF $L($G(DL(DQ)))*8+$L(DIS(DQ))+$L(Y)>180 DO
117 . SET Y=$$OVFL(Y)_" I $T"
118 . IF $L(Y)+$L(DIS(DQ))>235 SET DIS(DQ)=$$OVFL(DIS(DQ))_" IF "
119 SET DIS(DQ)=DIS(DQ)_" "_Y
120 QUIT
121 ;
122OVFL(Y) N I,%
123 FOR I=1:1 SET %=DQ_"@"_IF QUIT:'$D(DIS(%))
124 SET DIS(%)=Y
125 QUIT "X DIS("""_%_""")"
126 ;
127X SET D=DY(-DU),O=+D,DC=U_$P(D,U,2) FOR %=66:1 SET M=DQ_$C(%) QUIT:'$D(DIS(M))
128 IF $P(D,U,3) DO
129 . SET M=DQ_U_$P(D,U,3)
130 . SET Y="S DIXX="""_M_""" "_$P("X ""I 0"" ^I 1 ",U,DN=3+1)_$P(D,U,4,99)_" I $T"
131 . SET R(M)=DN
132 ELSE SET Y=$P(D,U,4,99)_" S D0=D(0) X DIS("""_M_""") S D0=I(0,0) I $T"
133 DO SD
134 SET DQ=M
135 SET DI(DL)=DC
136 SET DK(DL)=+D
137 SET DQ(DL)=DQ
138 SET D=0
139 SET Z="D0,"
140 GOTO N
141 ;
142TMGDONE QUIT
Note: See TracBrowser for help on using the repository browser.