source: WorldVistAEHR/trunk/r/VISTALINK-XOBV/XOBVTCP.m@ 1006

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

initial load of WorldVistAEHR

File size: 5.3 KB
RevLine 
[613]1XOBVTCP ;; mjk/alb - VistALink TCP Utilities ; 07/27/2002 13:00
2 ;;1.5;VistALink;;Sep 09, 2005
3 ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
4 ;
5 QUIT
6 ;
7 ; -- called from protocol action at START^XOBUM1
8START(XOBPORT,XOBCFG) ;
9 ;
10 ; -- set up environment
11 NEW XOBOK
12 SET XOBOK=0
13 SET U="^" DO HOME^%ZIS
14 ;
15 ; -- if no port, set to default
16 IF $GET(XOBPORT)="" NEW XOBPORT SET XOBPORT=8000
17 ;
18 IF $$LOCK(XOBPORT) DO
19 . DO UNLOCK(XOBPORT)
20 . ; -- JOB command same for CacheNT and DSM
21 . JOB LISTENER^XOBVTCPL(XOBPORT,$GET(XOBCFG))::5
22 . SET XOBOK=$TEST
23 ELSE DO
24 . SET XOBOK=0
25 QUIT XOBOK
26 ;
27UCX ; -- VMS TCPIP (UCX) multi-thread entry point
28 ; -- Called from VistALink .com files
29 ;
30 NEW XOBEC
31 DO ESET
32 SET (IO,IO(0))="SYS$NET"
33 ; **VMS specific code, need to share device**
34 OPEN IO:(TCPDEV:BLOCKSIZE=512):60 ELSE SET ^TMP("XOB DSM CONNECT FAILURE",$HOROLOG)="" QUIT
35 USE IO
36 SET XOBEC=$$NEWOK^XOBVTCPL()
37 IF XOBEC DO LOGINERR^XOBVTCPL(XOBEC,IO)
38 IF 'XOBEC DO SPAWN^XOBVLL
39 QUIT
40 ;
41CACHEVMS ; -- VMS TCPIP (UCX) multi-thread entry point for Cache for VMS
42 ; -- Called from VistALink .com files
43 ;
44 NEW XOBEC
45 DO ESET
46 SET (IO,IO(0))="SYS$NET"
47 ;
48 ; **Cache'/VMS specific code**
49 OPEN IO::5
50 USE IO:(::"-M") ;Packet mode like DSM
51 ;
52 SET XOBEC=$$NEWOK^XOBVTCPL()
53 IF XOBEC DO LOGINERR^XOBVTCPL(XOBEC,IO)
54 IF 'XOBEC DO SPAWN^XOBVLL
55 QUIT
56 ;
57ESET ;Set inital error trap
58 SET U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
59 QUIT
60 ;
61STARTUP ; -- called by TaskMan startup option [Option: XOBV LISTENER STARTUP]
62 ; and could be called by VMS .com procedure
63 ;
64 ; -- quit if not Cache OS
65 IF $$GETOS()'["OpenM" GOTO STARTUPQ
66 ; -- clear log of non-active listeners
67 DO CLEARLOG
68 ; -- get config for BOX-VOL and start it!
69 DO STARTCFG($$GETCFG())
70STARTUPQ ;
71 QUIT
72 ;
73CLEARLOG ; -- clear log of non-active listeners
74 NEW DIK,DA,Y,XOBI,XOB0,XOBPORT
75 ;
76 SET XOBI=0
77 FOR SET XOBI=$ORDER(^XOB(18.04,XOBI)) QUIT:'XOBI DO
78 . SET XOB0=$GET(^XOB(18.04,XOBI,0))
79 . SET XOBPORT=+$PIECE(XOB0,U,2)
80 . ; -- make sure listener is not running
81 . IF $$LOCK(XOBPORT) DO
82 . . SET DIK="^XOB(18.04,",DA=XOBI DO ^DIK
83 . . DO UNLOCK(XOBPORT)
84 ;
85 QUIT
86 ;
87STARTCFG(XOBCFG) ; -- start a configurations listeners
88 NEW CFG0,LSTR,LSTR0,XOBPORT,STARTUP,XOBOK
89 SET CFG0=$GET(^XOB(18.03,XOBCFG,0))
90 ;
91 ; -- quit if no configuration
92 IF CFG0="" GOTO CFGQ
93 ;
94 ; -- quit if not Cache...for now!
95 IF $$GETOS()'["OpenM" GOTO CFGQ
96 ;
97 SET LSTR=0
98 FOR SET LSTR=$ORDER(^XOB(18.03,XOBCFG,"PORTS",LSTR)) QUIT:'LSTR DO
99 . SET LSTR0=$GET(^XOB(18.03,XOBCFG,"PORTS",LSTR,0))
100 . SET XOBPORT=+$PIECE(LSTR0,U,1)
101 . SET STARTUP=$PIECE(LSTR0,U,2)
102 . ;
103 . ; -- if ok to start, port # defined and not already started
104 . IF XOBPORT,STARTUP,$$LOCK^XOBVTCP(XOBPORT) DO
105 . . DO UNLOCK(XOBPORT)
106 . . DO UPDATE^XOBVTCP(XOBPORT,1,XOBCFG)
107 . . SET XOBOK=$$START(XOBPORT,XOBCFG)
108 . . IF 'XOBOK DO UPDATE(XOBPORT,5,XOBCFG)
109 ;
110CFGQ ;
111 QUIT
112 ;
113LOCK(XOBPORT) ;-- Lock port
114 ;
115 ; Used to prevent another process from attempting to start the Listener
116 ; when it is already running.
117 ;
118 ; Input:
119 ; XOBPORT - Port #
120 ;
121 ; Output:
122 ; Function Value - Returns 1 if lock was successful, 0 otherwise
123 ;
124 QUIT $$ACTION("LOCK",XOBPORT)
125 ;
126 ;
127UNLOCK(XOBPORT) ;-- Unlock port
128 ;
129 ; Used to release a lock created by $$LOCK.
130 ;
131 ; Input:
132 ; XOBPORT - Port #
133 ;
134 ; Output:
135 ; None
136 ;
137 NEW X
138 SET X=$$ACTION("UNLOCK",XOBPORT)
139 QUIT
140 ;
141ACTION(ACTION,XOBPORT) ; -- do lock action
142 NEW ENV,VOL,UCI,BOX
143 ;
144 SET XOBPORT=+$GET(XOBPORT)
145 ;
146 SET ENV=$$GETENV()
147 SET VOL=$PIECE(ENV,U,2)
148 SET UCI=$PIECE(ENV,U)
149 SET BOX=$PIECE(ENV,U,4)
150 ;
151 IF ACTION="LOCK",XOBPORT LOCK +^XOB(18.01,"VistALink Listener",VOL,UCI,BOX,XOBPORT):1 QUIT $TEST
152 IF ACTION="UNLOCK",XOBPORT LOCK -^XOB(18.01,"VistALink Listener",VOL,UCI,BOX,XOBPORT) QUIT 1
153 QUIT 0
154 ;
155 ;
156UPDATE(XOBPORT,XOBSTAT,XOBCFG) ; -- update VISTALINK LISTENER STARTUP LOG for listener
157 NEW DIC,Y,X,XOBBOX
158 SET XOBBOX=$$GETBOXN()
159 ;
160 ; -- set up lookup call
161 SET DIC="^XOB(18.04,"
162 SET DIC(0)="MLX"
163 SET DIC("DR")=".02////"_XOBPORT
164 SET DIC("S")="IF $P(^(0),U,2)="_XOBPORT
165 SET X=XOBBOX
166 ;
167 DO ^DIC
168 ; -- quit if lookup failed
169 IF +Y>0 DO UPDLOG(+Y,XOBPORT,XOBSTAT,$GET(XOBCFG))
170 QUIT
171 ;
172UPDLOG(XOBDA,XOBPORT,XOBSTAT,XOBCFG) ; -- do edit
173 NEW DA,DIE,DR,Y,X
174 ;
175 LOCK +^XOB(18.04,XOBDA,0)
176 ; -- set basic fields
177 SET DA=XOBDA
178 SET DIE="^XOB(18.04,"
179 SET DR=".02////"_XOBPORT_";.03////"_XOBSTAT_";.05////^S X=$$NOW^XLFDT"
180 ; -- set config if defined, otherwise delete
181 SET DR=DR_";.06////"_$SELECT($GET(XOBCFG)]"":XOBCFG,1:"@")
182 ; -- set user if defined, otherwise delete
183 SET DR=DR_";.04////"_$SELECT($GET(DUZ)]"":DUZ,1:"@")
184 ;
185 DO ^DIE
186 LOCK -^XOB(18.04,XOBDA,0)
187 ;
188 QUIT
189 ;
190GETENV() ; -- get environment variable
191 ;-- Get environment of current system i.e. Y=UCI^VOL/DIR^NODE^BOX LOOKUP
192 NEW Y
193 DO GETENV^%ZOSV
194 QUIT Y
195 ;
196GETOS() ;-- Get operating system
197 ;
198 ; This function will determine which operating system is being used.
199 ;
200 ; Input:
201 ; None
202 ;
203 ; Output:
204 ; Operating system value i.e. OpenM-NT for OpenM.
205 ;
206 ;-- Get operating system
207 QUIT $PIECE($GET(^%ZOSF("OS")),"^")
208 ;
209 ;
210GETBOX() ; -- get box ien
211 ;
212 QUIT $$FIND1^DIC(14.7,"","BX",$PIECE($$GETENV(),U,4),"","","")
213 ;
214GETBOXN() ; -- get box name
215 ;
216 QUIT $PIECE($$GETENV(),U,4)
217 ;
218GETCFG() ; -- get config ien for current BOX-VOL pair
219 QUIT +$PIECE($GET(^XOB(18.01,1,"CONFIG",+$ORDER(^XOB(18.01,1,"CONFIG","B",+$$GETBOX(),"")),0)),U,2)
220 ;
Note: See TracBrowser for help on using the repository browser.