source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDS.m@ 1042

Last change on this file since 1042 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.2 KB
Line 
1DDS ;SFISC/MLH,MKO-MAIN ROUTINE ;21SEP2006
2 ;;22.0;VA FileMan;**151**;Mar 30, 1999;Build 10
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 N DIE,DX,DY,X,Y
5 K DDSCTRL ;DI*151
6 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
7 ;
8 D EN^DDS0(.DDSFILE,DR,.DA)
9 I $G(DIERR) D:$G(DDSPARM)'["E" G END^DDS0
10 . W !,$C(7)_$$EZBLD^DIALOG(3000)
11 . D MSG^DIALOG("BW")
12 . S DIMSG=""
13 ;
14 N DR
15 X:$G(^DIST(.403,+DDS,11))'?."^" ^(11)
16 F D PG Q:DDACT="Q"
17 X:$G(^DIST(.403,+DDS,12))'?."^" ^(12)
18 ;
19 D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
20 G END^DDS0
21 ;
22PROC ;Main loop
23 F D PG Q:DDACT="Q"
24 Q
25 ;
26PG ;Load page
27 S DDACT="N"
28 D ^DDS1(DDSPG)
29 I $G(DIERR) D Q
30 . N P S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U)
31 . S:P(2)="" P(2)="unnamed"
32 . D BLD^DIALOG(3041,.P),ERR^DDSMSG H 2
33 . S DDACT="Q"
34 ;
35 ;Pre-action, save old and get next page
36 S DDSOPB=DDSPG
37 I $G(^DIST(.403,+DDS,40,DDSPG,11))'?."^" D PA(^(11)) Q:DDACT="NP"
38 S DDSNP=$$NP^DDS5(.Y) S:'Y DDSNP=""
39 ;
40 ;Get DDO and DDSBK
41 I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D
42 . S DDO=+$G(@DDSREFS@(DDSPG,"FIRST")),DDSBK=$P($G(^("FIRST")),",",2)
43 I 'DDSBK D Q
44 . D BLD^DIALOG(3055,"number "_$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U)_$S($G(^(1))]"":" ("_$P($G(^(1)),U)_")",1:""))
45 . D ERR^DDSMSG H 2
46 . S DDACT="Q"
47 ;
48 ;Get DDSPOP and update DDSSC array
49 ;If we're going to another page
50 I '$D(DDSPGUP) D
51 . S DDSLN=^DIST(.403,+DDS,40,DDSPG,0),DDSPOP=$P(DDSLN,U,6)
52 . K:'DDSPOP DDSSC
53 . I $D(DDSSEL) D
54 .. S DDSDASV=DDSDA,DDSDLSV=DDSDL
55 .. M DDSORGSV=DDSDAORG
56 .. K DA,@$$D0(DDSDL),DDSDAORG
57 .. S (DA,D0,DDSDAORG)="",DDSDA="0,",DDSDL=0
58 . I '$D(DDSSC("B",DDSPG)) D
59 .. S DDSSC=$G(DDSSC)+1,DDSSC(DDSSC)=DDSPG,DDSSC("B",DDSPG,DDSSC)=""
60 .. S:DDSPOP $P(DDSSC(DDSSC),U,2,3)=$P(DDSLN,U,3)_U_$P(DDSLN,U,7)
61 .. I $G(DDSSTK) S $P(DDSSC(DDSSC),U,4)=1 K DDSSTK
62 .. K DDSPOP
63 . E D
64 .. Q:$P($G(DDSSC(+$G(DDSSC))),U)=DDSPG
65 .. N I,J,S
66 .. S I=$O(DDSSC("B",DDSPG,"")),S=DDSSC(I) K DDSSC("B",DDSPG,I)
67 .. F J=I:1:DDSSC-1 D
68 ... K DDSSC("B",$P(DDSSC(J+1),U),J)
69 ... S DDSSC(J)=DDSSC(J+1),DDSSC("B",$P(DDSSC(J),U),J)=""
70 .. S DDSSC(DDSSC)=S,DDSSC("B",DDSPG,DDSSC)=""
71 ;
72 ;If we've moving up from a pop-up page
73 E K DDSPGUP
74 ;
75 ;Paint the page
76 D RP^DDSR(DDSSC(DDSSC),DDSSC=1)
77 ;
78P1 F D BLK Q:"^Q^NP^"[(U_DDACT_U)
79 ;
80 ;PAGE Post action, print any help
81 D:$G(^DIST(.403,+DDS,40,+DDSOPB,12))'?."^" PA(^(12))
82 D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
83 G:"^NB^N^"[(U_DDACT_U) P1
84 ;
85 I DDACT="Q" D
86 . I '$P(DDSSC(DDSSC),U,4) D
87 .. I $G(DDSSEL) D GDA^DDSRSEL Q:'DA
88 .. D:$G(DDSSC)>1 CLEAR^DDSBOX($P(DDSSC(DDSSC),U,2),$P(DDSSC(DDSSC),U,3))
89 .. S:DDSSC>1 DDSPG=$P(DDSSC(DDSSC-1),U),DDACT="N",DDSPGUP=1
90 . K DDSSC("B",$P(DDSSC(DDSSC),U),DDSSC),DDSSC(DDSSC) S DDSSC=DDSSC-1
91 Q
92 ;
93BLK S DDACT="N",DDSOSV=0
94 ;
95 I $D(@DDSREFS@(DDSPG,DDSBK))[0 S DDACT="Q" Q
96 S DDSLN=@DDSREFS@(DDSPG,DDSBK)
97 ;
98 S DDSDN=$P(DDSLN,U,4),DDSTP=$P(DDSLN,U,5)
99 S DDSREP=$P(DDSLN,U,7),DDSPTB=$P(DDSLN,U,8)
100 K:'DDSDN DDSDN K:DDSTP="e" DDSTP K:'DDSPTB DDSPTB K:DDSREP'>1 DDSREP
101 ;
102 I $D(DDSPTB)!$D(DDSREP) N DDP,DDSDA,DIE D
103 . S DDP=$P(DDSLN,U,3)
104 . S DDSDA=$P(@DDSREFT@(DDSPG,DDSBK),U) Q:'DDSDA
105 . S DIE=@DDSREFT@(DDSPG,DDSBK,DDSDA,"GL")
106 ;
107 I $D(DDSPTB) N DA,@$$D0(DDSDL),DDSDL D
108 . S DDSPTB=@DDSREFS@(DDSPG,DDSBK,"PTB")
109 . S DDSDL=$L(DDSDA,",")-2
110 . S (D0,DA)=+DDSDA
111 ;
112 I $D(DDSREP) N DDSDL,DA D
113 . S DDSREP=$P(@DDSREFT@(DDSPG,DDSBK,DDSDA),U,2,999)
114 . S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,$P(DDSREP,U),$P(DDSREP,U,4)),"0,"_DDSDA)
115 . S:'$P(DDSREP,U,7) DDSDA=$P(DDSDA,",")_","
116 . S DDSDL=$L(DDSDA,",")-2
117 I N @$$D0(DDSDL) D
118 . D BLDDA(DDSDA)
119 . S:'DA DDO=+$P(DDSREP,U,8)
120 ;
121 I $D(DDSPTB),'$D(DDSREP),'DDSDA,DDSDAORG D Q
122 . N DDSBK0
123 . S DDSBK0=DDSBK
124 . F S DDSBK=$$NB^DDS5(.Y) Q:DDSBK=DDSBK0!'Y!$G(@DDSREFT@(DDSPG,DDSBK))
125 . Q:Y
126 . I DDSNP]"" S DDSPG=DDSNP,DDACT="NP" Q
127 . S DDSPG=$$PP^DDS5(.Y) I Y S DDACT="NP" Q
128 . S DDACT="Q"
129 ;
130 S $P(DDSOPB,U,2)=DDSBK
131 I $G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP"
132 I $G(^DIST(.404,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP"
133 I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D
134 . S DDO=$P(@DDSREFS@(DDSPG,DDSBK),U,9)
135 K DDSLN
136 ;
137B1 D ^DDS01
138 ;
139 I $G(^DIST(.403,+DDS,40,DDSPG,40,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1
140 I $G(^DIST(.404,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1
141 Q
142 ;
143BLDDA(DDSDA) ;
144 N I
145 S (DA,@("D"_DDSDL))=$P(DDSDA,",")
146 F I=1:1:DDSDL S (DA(I),@("D"_(DDSDL-I)))=$P(DDSDA,",",I+1)
147 Q
148 ;
149D0(DL) ;Given DL, return string D0,D1,...,Dn
150 N I,S
151 S S="" F I=0:1:DL S S=S_"D"_I_","
152 S:S?.E1"," S=$E(S,1,$L(S)-1)
153 Q S
154 ;
155CLRMSG ;
156 I $G(DDSKM) H 2 K DDSKM ;GFT ** IF WE WERE KEEPING SOMETHING IN HELP AREA, HOLD UP 2 SECONDS ISB-0603-31054
157 K DDQ S DDSH=1,(DDM,DX)=0,DY=DDSHBX+1 X DDXY W $P(DDGLCLR,DDGLDEL,3)
158 Q
159 ;
160PA(DDSPA) ;
161 N DDSBRORG S:$D(DDSBR)#2 DDSBRORG=DDSBR
162 K DDSBR X DDSPA
163 I $D(DDSBR)[0 S:$D(DDSBRORG)#2 DDSBR=DDSBRORG Q
164 D BR^DDS2
165 Q
166RESET ;Programmer entry point to reset terminal and cleanup
167 D INIT^DDGLIB0() D:$G(DIERR) MSG^DIALOG("BW")
168 W $P($G(DDGLVID),DDGLDEL,10)
169 K DDSPARM
170 S DDSREFT="^TMP(""DDS"",$J)"
171 D END^DDS0
172 G RESET^DDGF
173 ;
174RUN ;Run a form
175 G ^DDSRUN
176CLONE ;Clone a form
177 G ^DDSCLONE
178PRINT ;Print a form
179 G ^DDSPRNT
180DFRM ;Delete a form
181 G ^DDSDFRM
182DBLK ;Delete unused blocks
183 G ^DDSDBLK
Note: See TracBrowser for help on using the repository browser.