source: WorldVistAEHR/trunk/r/VISTALINK-XOBV/XOBVTCPL.m@ 1556

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

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1XOBVTCPL ;; mjk/alb - VistALink TCP/IP Listener (Cache NT) ; 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 ; -- Important: Should always be JOBed using START^XOBVTCP
8LISTENER(XOBPORT,XOBCFG) ; -- Start Listener
9 ;
10 ; -- quit if not Cache for NT
11 IF $$GETOS^XOBVTCP()'="OpenM-NT" QUIT
12 ;
13 NEW $ETRAP,$ESTACK SET $ETRAP="D ^%ZTER HALT"
14 ;
15 NEW X,POP,XOBDA,U,DTIME,DT,XOBIO
16 SET U="^",DTIME=900,DT=$$DT^XLFDT()
17 IF $GET(DUZ)="" NEW DUZ SET DUZ=.5,DUZ(0)="@"
18 ;
19 ; -- only start if not already started
20 IF $$LOCK^XOBVTCP(XOBPORT) DO
21 . IF $$OPENM(.XOBIO,XOBPORT) DO
22 . . ; -- listener started and now stopping
23 . . SET IO=XOBIO
24 . . DO CLOSE^%ZISTCP
25 . . ; -- update status to 'stopped'
26 . . DO UPDATE^XOBVTCP(XOBPORT,4,$GET(XOBCFG))
27 . ELSE DO
28 . . ; -- listener failed to start
29 . . ; -- update status to 'failed'
30 . . DO UPDATE^XOBVTCP(XOBPORT,5,$GET(XOBCFG))
31 . ;
32 . DO UNLOCK^XOBVTCP(XOBPORT)
33 QUIT
34 ;
35 ; -- open/start listener port
36OPENM(XOBIO,XOBPORT) ;
37 NEW XOBBOX,%ZA
38 SET XOBBOX=+$$GETBOX^XOBVTCP()
39 SET XOBIO="|TCP|"_XOBPORT
40 OPEN XOBIO:(:XOBPORT:"AT"):30
41 ;
42 ; -- if listener port could not be openned then gracefully quit
43 ; (other namespace using port maybe?)
44 IF '$TEST QUIT 0
45 ;
46 ; -- indicate listener is 'running'
47 DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG))
48 ; -- read & spawn loop
49 FOR DO QUIT:$$EXIT(XOBBOX,XOBPORT)
50 . USE XOBIO
51 . READ *X:60 IF '$TEST QUIT
52 . JOB CHILDNT^XOBVTCPL():(:4:XOBIO:XOBIO):10 SET %ZA=$ZA
53 . IF %ZA\8196#2=1 WRITE *-2 ;Job failed to clear bit
54 QUIT 1
55 ;
56CHILDNT() ;Child process for OpenM
57 NEW XOBEC
58 SET $ETRAP="D ^%ZTER L HALT"
59 SET IO=$PRINCIPAL ;Reset IO to be $P
60 USE IO:(::"-M") ;Packet mode like DSM
61 ; -- do quit to save a stack level
62 SET XOBEC=$$NEWOK()
63 IF XOBEC DO LOGINERR(XOBEC,IO)
64 IF 'XOBEC DO VAR,SPAWN^XOBVLL
65 QUIT
66 ;
67VAR ;Setup IO variables
68 SET IO(0)=IO,IO(1,IO)="",POP=0
69 SET IOT="TCP",IOF="#",IOST="P-TCP",IOST(0)=0
70 QUIT
71 ;
72NEWOK() ;Is it OK to start a new process
73 NEW XQVOL,XUVOL,X,XOBCODE,Y
74 SET U="^"
75 DO GETENV^%ZOSV SET XQVOL=$PIECE(Y,U,2)
76 SET X=$$FIND1^DIC(8989.304,",1,","BX",XQVOL,"","",""),XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
77 SET XOBCODE=$$INHIBIT^XUSRB()
78 IF XOBCODE=1 QUIT 181004
79 IF XOBCODE=2 QUIT 181003
80 QUIT 0
81 ;
82 ; -- process error
83LOGINERR(XOBEC,XOBPORT) ;
84 DO ERROR^XOBVLL(XOBEC,$$EZBLD^DIALOG(XOBEC),XOBPORT)
85 ;
86 ; -- give client time to process stream
87 HANG 2
88 QUIT
89 ;
90EXIT(XOBBOX,XOBPORT) ;
91 ; -- is status 'stopping'
92 QUIT ($PIECE($GET(^XOB(18.04,+$$GETLOGID(XOBBOX,XOBPORT),0)),U,3)=3)
93 ;
94GETLOGID(XOBBOX,XOBPORT) ;
95 QUIT +$ORDER(^XOB(18.04,"C",XOBBOX,XOBPORT,""))
96 ;
Note: See TracBrowser for help on using the repository browser.