source: IHS-VA_UTILITIES-XB/trunk/XBVCH1.m@ 1650

Last change on this file since 1650 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.
File size: 5.4 KB
RevLine 
[641]1XBVCH1 ; IHS/ADC/GTH - CONTINUE VARIABLE CHANGER ; [ 10/29/2002 7:42 AM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4 ; Thanks to Paul Wesley, DSD/OIRM, for the original routine.
5 ;
6PROCESS ;
7 S XBL=$L(XBV0),XBOUT=0
8 S X=0
9 X ^%ZOSF("RM")
10 S (XBROU,XBRM)=""
11 F S XBROU=$O(^XBVROU(XBJ,"R",XBROU)) Q:XBROU="" S XBRM=XBRM_XBROU_","
12 S XBROU=""
13 F S XBROU=$O(^XBVROU(XBJ,"R",XBROU)) Q:XBROU="" D Q:$G(XBOUT)
14 . S X=XBROU
15 . X ^%ZOSF("TEST")
16 . E D ^XBCLS W !!,X," NOT FOUND",! KILL DIR S DIR(0)="E" D ^DIR S:(Y=0) XBOUT=1 Q
17 . S X=XBROU,DIF="^XBVROU(XBJ,""R"","""_XBROU_""",",(XCNP,%N)=0
18 . X ^%ZOSF("LOAD")
19 . I ^XBVROU(XBJ,"R",XBROU,1,0)["GENERATED FROM" W !,^(0),! KILL DIR S DIR(0)="E" D ^DIR D ^XBCLS Q
20 . S XBLN=0,XBEDIT=0
21 . F S XBLN=$O(^XBVROU(XBJ,"R",XBROU,XBLN)) Q:XBLN="" S XBLIN=^(XBLN,0) D LIN Q:$G(XBOUT)
22 . I XBEDIT D SAVE
23 . KILL ^XBVROU(XBJ,"R",XBROU)
24 .Q
25 Q
26 ;
27DISPROU ;display routine list
28 S DX=1,DY=22
29 X XBXY
30 S XBRD=""
31 F XBRI=1:1 S XBRD=$P(XBRM,",",XBRI) Q:XBRD="" W:'(XBRI-1#8) ! S XBRC=(10*(XBRI-1#8)) W ?XBRC W:XBRD=XBROU "|" W XBRD W:XBRD=XBROU "|"
32 Q
33 ;
34 ;--------------------------------------
35 ;
36LIN ;PROCESS LINE FROM TOP
37 S XBLIN0=XBLIN,XBVX=XBV0
38 Q:XBLIN0'[XBV0
39 D SCAN0,CHKMK
40 I '$G(XBMK),$L(XBV0)=1 Q ;skip when single character variable
41 I '$G(XBMK) KILL XBEDLIN D EDIT,CHKMK Q:'$G(XBMK) Q:$G(XBOUT)
42 D ACCEPT
43 Q
44 ;
45SCAN0 ;
46 S XBLINX=XBLIN0,XBVX=XBV0
47 D SCAN,UPT
48 Q
49 ;
50SCAN1 ;
51 S XBLINX=XBLIN1,XBVX=XBV1
52 D SCAN
53 Q
54 ;
55DISP0 ;
56 S XBVX=XBV0,XBLINX=XBLIN0
57 D ^XBCLS,DISPLAY
58 Q
59 ;
60DISP1 ;
61 S XBVX=XBV1,XBLINX=XBLIN1
62 D DISPLAY
63 Q
64 ;
65SCAN ;
66 KILL XB,XBT,XBMK
67 S XBL=$L(XBVX)
68 F XBI=1:1 S XB(XBI)=$F(XBLINX,XBVX,$G(XB(XBI-1))+1)-XBL Q:XB(XBI)'>0 D
69 . S XB(XBI,"M")=0,XB(XBI,0)=XB(XBI)
70 . I XBP[$E(XBLINX,XB(XBI)-1),XBS[$E(XBLINX,XB(XBI)+XBL) S XB(XBI,"M")=1
71 . S XB("B",XB(XBI))=XBI,XB("E",XB(XBI)+XBL-1)=XBI
72 . S XB(XBI,"E")=XB(XBI)+XBL-1
73 .Q
74 KILL XB(XBI)
75CHKMK ;
76 I XBVX=XBV0 KILL XBMK S XBJM="" F S XBJM=$O(XB(XBJM)) Q:XBJM="" I $G(XB(XBJM,"M")) W *7 S XBMK=1
77 KILL XBJM
78 Q
79 ;
80EDIT ;
81 D DISP0
82 S DX=1,DY=13
83 X XBXY
84 R "TAB/T/SPC/CR/R/N/%/^/? :",*X:DTIME
85 S X=$C(X)
86 I X="T" D UPT G EDIT
87 I $A(X)=9 D UPT G EDIT
88 I X=" " S XB(XBT,"M")=XB(XBT,"M")+1#2 D UPT G EDIT
89 I X="R" S XBLN=0 KILL XBMK Q
90 I X="N" S XBLN=999 KILL XBMK Q
91 ; I X="%" D ^XBNEW("%EDIT^XBVCH1:XBJ;XBROU") S XBLN=0 KILL XBMK Q ; IHS/SET/GTH XB*3*9 10/29/2002
92 I X="%" D EN^XBNEW("%EDIT^XBVCH1","XBJ;XBROU") S XBLN=0 KILL XBMK Q ; IHS/SET/GTH XB*3*9 10/29/2002
93 I X="^" S XBOUT=1 KILL XBMK Q
94 KILL XBMK
95 S XBJM=""
96 F S XBJM=$O(XB(XBJM)) Q:XBJM="" I $G(XB(XBJM,"M")) W *7 S XBMK=1
97 KILL XBJM
98 I $A(X)=13 Q
99 D ^XBCLS
100 W !!!
101 W !?5,"'X' Set changes"
102 W !?5,"'Tab' or 'T' Move to next marker"
103 W !?5,"'Space bar' Toggel marker and move to next"
104 W !?5,"'CR' Skip to next line"
105 W !?5,"'R' Restart the current Routine"
106 W !?5,"'%' %E Edit Routine"
107 W !?5,"'N' Next Routine"
108 W !?5,"'^' Exit"
109 KILL DIR
110 S DIR(0)="E"
111 D ^DIR
112 G EDIT
113 ;
114DISPLAY ; display line
115 ; XB(XBI,0)=POS XB("B",POS)=XBI XB("E",POS)=XBI XB(XBI,"M")=MARK (0 OR 1)
116 ; XBD(0) =underline-on,XBD(1)=Bold on,XBD(2)=Underline Off,XBD(3)=Bold Off,XBD("RVON")=RVON,XBD("RVOFF")=RVOFF
117 D:(XBVX=XBV0) ^XBCLS ;displaying current line
118 D:XBVX=XBV0 DISPROU
119 S DX=0,DY=0
120 X XBXY
121 W ?5,"routine ",XBROU,?35,"line ",XBLN,!!
122 I XBVX=XBV1 W ! ;displaying new line
123 W XBD(6)
124 F XBI=1:1:$L(XBLINX) D
125 . I '(XBI#80) W !!!
126 . I $D(XB("B",XBI)) W XBD(XB(XB("B",XBI),"M")*2)
127 . W $E(XBLINX,XBI)
128 . I $D(XB("E",XBI)) W XBD(XB(XB("E",XBI),"M")*2+1)
129 .Q
130 W XBD(7)
131 Q:(XBVX=XBV1) ;no tab marker when displaying new line
132TAB ;
133 S DY=+3,DX=XB(XBT,0)#80-1,DY=DY+(XB(XBT,0)\80*3)
134 S:DY>8 DX=DX+1
135TAB1 ;
136 X XBXY
137 W XBD(2),"|",XBD(3)
138 Q
139 ;
140UPT ; SET TAB
141 S XBT=$G(XBT),XBT=$O(XB(XBT))
142 I XBT'>0 S XBT=0 G UPT
143 KILL XB("T")
144 S XB("T",XB(XBT,0))=""
145 Q
146 ;
147BLDLIN1 ;
148 S XBLIN0=XBLIN,XBSUB=XBV0_":"_XBV1,XBLIN1=""
149 F XBI=1:1 Q:'$D(XB(XBI)) S XBLIN1=XBLIN1_$E(XBLIN,$G(XB(XBI-1,"E"))+1,XB(XBI,0)-1)_$S(XB(XBI,"M"):XBV1,1:XBV0)
150 S XBI=XBI-1
151 S XBLIN1=XBLIN1_$E(XBLIN,XB(XBI,"E")+1,999)
152 Q
153 ;
154ACCEPT ;
155 D DISP0,BLDLIN1,SCAN1,DISP1
156 KILL DIR
157 S DIR(0)="S^Y:ACCEPT;E:EDIT;S:SKIP;N:NEXT ROUTINE;Q:QUIT",DIR("B")="Y"
158 S X=$P(XBLINX," ",2,999)
159 F Q:$E(X)'=" " S X=$E(X,2,999)
160 F Q:$E(X)'="." S X=$E(X,2,999)
161 D ^DIM
162 I '$D(X) W *7,!,XBD(2),"FM DIM checker does not like this line !",XBD(3),!,XBD(2),XBLINX,XBD(3),! S DIR("B")="E"
163 D ^DIR
164 KILL DIR
165 I Y="N" S XBLN=999 Q
166 I Y="S" Q
167 I Y="E" D SCAN0,EDIT,CHKMK G:$G(XBMK) ACCEPT Q
168 I Y="Q" S XBOUT=1 Q
169 I Y'="Y" G ACCEPT
170 S XBEDIT=1 ; set edit markers
171 S XBLIN=XBLIN1,^XBVROU(XBJ,"R",XBROU,XBLN,0)=XBLIN ;set new line
172 Q
173 ;
174%EDIT ; USE %E EDITOR
175 X "ZL @XBROU X ^%E"
176 KILL ^XBVROU(XBJ,"R",XBROU)
177 S X=XBROU,DIF="^XBVROU(XBJ,""R"","""_XBROU_""",",(XCNP,%N)=0
178 X ^%ZOSF("LOAD")
179 S XBLIN=0
180 Q
181 ;
182SAVE ; SAVE NEW ROUTINE TO DISK
183 D ^XBCLS
184 X ^%ZOSF("UCI")
185 I Y["DEV," W !,"you are in DEV .. NO CHANGES" H 2 Q
186 I Y["PRD," W !,"you are in PRD .. NO CHANGES" H 2 Q
187 KILL DIR
188 S DIR(0)="Y",DIR("A")=XBROU_" has been changed. Save with Changes ?",DIR("B")="Y"
189 D ^DIR
190 KILL DIR
191 I 'Y W !?5,XBROU," NOT CHANGED" H 3 D ^XBCLS Q
192 W !?5,XBROU,"is being saved with changes",!
193 S XBSAV1="ZR",XBSAV2="F XBI=1:1 S XBX=$G(^XBVROU(XBJ,""R"",XBROU,XBI,0)) Q:'$L(XBX) ZI XBX",XBSAV3="ZS @XBROU"
194 X "X XBSAV1,XBSAV2,XBSAV3"
195 S ^XBVROU("PRT",$J,"VCHG",XBSUB,XBROU)=""
196 S ^XBVROU("PRT",$J,"RCHG",XBROU,XBSUB)=""
197 S ^XBVROU(XBJ,"NV",XBV1)=""
198 W !?5,XBROU,"SAVED WITH CHANGES" H 2
199 Q
200 ;
Note: See TracBrowser for help on using the repository browser.