source: FOIAVistA/trunk/r/VISTALINK_SECURITY-XOBS/XOBSCAV1.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 9.5 KB
Line 
1XOBSCAV1 ;; kec/oak - VistaLink Access/Verify Security ; [6/28/06 2:26pm]
2 ;;1.5;VistALink Security;**1**;Sep 09, 2005;Build 3
3 ;;Foundations Toolbox Release v1.5 [Build: 1.5.1.001]
4 ;;
5 QUIT
6 ;
7 ; Access/Verify Security: Security Message Request Handler
8 ; specific message request/response pairs)
9 ;
10 ; ** Setting/Killing of DUZ covered by blanket SAC Kernel exemption for Foundations
11 ;
12 ; ::AV.SetupAndIntroText.Request message processing
13SENDITXT ; Do Setup and send Intro Text
14 NEW XOBSTINF,XOBITINF,XOBMSG,XOBTMP,XOBTMP1,XOBCCMSK,XOBI,XOBPROD
15 ;
16 IF $$PRODMISM() DO QUIT
17 . NEW XOBSPAR SET XOBSPAR(1)=$GET(XOBDATA("CLIENTISPRODUCTION")),XOBSPAR(2)=$SELECT($$PROD^XUPROD(0):"true",1:"false")
18 . DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Production-Test Mismatch",183007,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183007,.XOBSPAR)))
19 ;
20 IF $$STATMISM() DO QUIT
21 . NEW XOBSPAR SET XOBSPAR(1)=$GET(XOBDATA("CLIENTPRIMARYSTATION")),XOBSPAR(2)=XOBSYS("PRIMARY STATION#")
22 . DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Primary Station Mismatch",183010,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183010,.XOBSPAR)))
23 ;
24 ; Do SETUP^XUSRB to setup, then INTRO^XUSRB to get intro text
25 ; NOTE: $$GETPEER^%ZOSV fails for TCP_SERVICES listeners if COM file doesn't set up VISTA$IP logical
26 SET XWBTIP=$$GETPEER^%ZOSV ; XWBTIP needed by SETUP^XUSRB. Use of GETPEER^%ZOSV: DBIA #4056
27 ;
28 USE XOBNULL ; protect against direct writes to socket
29 ; note: SETUP/INTRO^XUSRB set current IO to null device
30 ;
31 IF XOBSYS("ENV")="j2ee" DO
32 . DO SETUP^XUSRB(.XOBSTINF,"") ; use of SETUP^XUSRB: DBIA #4054
33 ELSE DO QUIT:$GET(DUZ)>0
34 . SET XWBVER=1.1 ; to allow VistaLink to contact client agent
35 . DO SETUP^XUSRB(.XOBSTINF,"") ; use of SETUP^XUSRB: DBIA #4054
36 . ; start of auto-signon support
37 . SET DUZ=$$AUTOXWB^XUS1B() IF DUZ<1 KILL DUZ ; use of $$AUTOXWB^XUS1B: DBIA #4060
38 . IF $GET(DUZ)>0 DO NOW^XUSRB SET XUMSG=$$POST^XUSRB(0) IF XUMSG>0 KILL DUZ ; XUSRB calls: DBIA #4061
39 . ; do autosignon and quit if DUZ is set
40 . IF $GET(DUZ)>0 DO QUIT
41 . .USE XOBPORT ; restore current IO (the TCP port)
42 . .SET XOBRET(5)=0 DO LOGFIN
43 . .QUIT
44 . KILL XWBVER ; once auto-signon fails, don't need to contact client agent
45 . ; end of autosignon support
46 ;
47 ;if failed autosignon, continue w/intro text
48 DO INTRO^XUSRB(.XOBITINF) ; use of INTRO^XUSRB: DBIA #4054
49 ; ** use of USE command covered by blanket SAC Kernel exemption for Foundations
50 USE XOBPORT ; restore current IO (the TCP port)
51 ;
52 SET XOBMSG(1)="<SetupInfo serverName='"_$$CHARCHK^XOBVLIB(XOBSTINF(0))_"' volume='"
53 ; note: next line, "dtime" attribute value is not DTIME, but is the VistaLink heartbeat rate.
54 ; this is used by the J2SE client code to time out the client dialogs.
55 ; Value may be replaced w/a signon-specific site parameter later.
56 SET XOBMSG(1)=XOBMSG(1)_$$CHARCHK^XOBVLIB(XOBSTINF(1))_"' uci='"_$$CHARCHK^XOBVLIB(XOBSTINF(2))_"' device='"_$$CHARCHK^XOBVLIB(XOBSTINF(3))_"' numberAttempts='"_$$CHARCHK^XOBVLIB(XOBSTINF(4))_"' dtime='"_$$GETRATE^XOBVLIB()_"'/>"
57 ; add intro text
58 DO GETINTRO^XOBSCAV2("XOBMSG",2)
59 ;
60 DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGSETUP^XOBSCAV),";;",2),.XOBMSG,$$SUCCESS^XOBSCAV(),$PIECE($TEXT(SCHSETUP^XOBSCAV),";;",2))
61 QUIT
62 ; ::AV.Logon.Request message processing
63LOGON ; process login request
64 NEW XOBAC,XOBVC,XOBRET,XOBRETDV
65 ;
66 IF $$LOGGEDON^XOBSCAV DO QUIT
67 .DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Server Partition State",183003,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183003)))
68 ;
69 KILL DUZ ; if DUZ is around, it shouldn't be.
70 USE XOBNULL ; protect against direct writes to socket
71 ; try to logon w/avcodes
72 DO VALIDAV^XUSRB(.XOBRET,XOBDATA("XOB SECAV","AVCODE")) ; use of VALIDAV^XUSRB: DBIA#4054
73 USE XOBPORT ; restore current IO (the TCP port)
74 ;
75 ; if bad a/v code credentials
76 IF '+XOBRET(0),'+XOBRET(1),'+XOBRET(2) DO QUIT
77 . IF XOBSYS("ENV")="j2ee" DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Connector Proxy User Error",183008,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183008,$GET(XOBRET(3)))))
78 . ; look for particular error string which means IP is locked
79 . IF $GET(XOBRET(3))["Device/IP address is locked due" DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Logon Failed",182306,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(182306,$GET(XOBRET(3))))) QUIT
80 . ELSE DO LOGBADCD
81 ;
82 ; if Kernel says user needs to change verify code
83 IF '+XOBRET(0),'+XOBRET(1),XOBRET(2) DO LOGCVC QUIT
84 ;
85 IF '+XOBRET(0) DO QUIT ; there was an error
86 .NEW XOBSPAR
87 .SET XOBSPAR(1)=$GET(XOBRET(3))
88 .; look for particular error string which means too many invalid signon attempts
89 .IF XOBSPAR(1)["too many invalid sign" DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Logon Failed",183005,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183005,.XOBSPAR))) QUIT
90 .DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Logon Failed",183004,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183004,.XOBSPAR)))
91 ;
92 ; if user requested to change verify code
93 IF XOBDATA("XOB SECAV","REQUESTCVC")="true" DO LOGCVC QUIT
94 ;
95 ; if j2ee, test for connector proxy user
96 IF XOBSYS("ENV")="j2ee" QUIT:'$$ISCPROXY()
97 ;
98 ; at this point login was successful
99 DO LOGFIN
100 QUIT
101LOGFIN ; check the divisions, finish login now
102 NEW XOBRETDV DO DIVGET^XUSRB2(.XOBRETDV,DUZ) ; use of DIVGET^XUSRB2: DBIA #4055
103 IF '+XOBRETDV(0) DO QUIT
104 . DO LOGOK
105 . DO DUZSV^XOBVSYSI(.DUZ)
106 ; otherwise this is a multidivisional user
107 DO LOGSELDV(.XOBRETDV)
108 QUIT
109LOGBADCD ; response if bad a/v code pair
110 NEW XOBMSG
111 SET XOBMSG(1)="<"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"_$$CHARCHK^XOBVLIB(XOBRET(3))_"</"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"
112 DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGON^XOBSCAV),";;",2),.XOBMSG,$$FAILURE^XOBSCAV(),$PIECE($TEXT(SCHSIMPL^XOBSCAV),";;",2))
113 QUIT
114LOGCVC ; response if need to change vc
115 NEW XOBMSG,XOBLINE
116 SET XOBLINE=$$POSTTXT^XOBSCAV(.XOBRET,.XOBMSG)
117 SET XOBMSG(XOBLINE+1)="<"_$PIECE($TEXT(PARTTAG^XOBSCAV),";;",2)_" changeVerify=""true"" cvcHelpText="""_$$CHARCHK^XOBVLIB($$AVHLPTXT^XUS2())_""" />" ; use of AVHLPTXT^XUS2: DBIA #4057
118 SET XOBMSG(XOBLINE+2)="<"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"_$$CHARCHK^XOBVLIB(XOBRET(3))_"</"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"
119 DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGON^XOBSCAV),";;",2),.XOBMSG,$$PARTIAL^XOBSCAV(),$PIECE($TEXT(SCHPARTS^XOBSCAV),";;",2))
120 QUIT
121LOGSELDV(XOBDIVS) ; response if need to select division
122 ;XOBDIVS is in format of output from DIVGET^XUSRB2
123 NEW XOBMSG,XOBLINE
124 SET XOBLINE=$$POSTTXT^XOBSCAV(.XOBRET,.XOBMSG)
125 SET XOBLINE=$$ADDDIVS^XOBSCAV(.XOBDIVS,.XOBMSG)
126 DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGON^XOBSCAV),";;",2),.XOBMSG,$$PARTIAL^XOBSCAV(),$PIECE($TEXT(SCHPARTS^XOBSCAV),";;",2))
127 QUIT
128LOGOK ; response if everything's looking good
129 NEW XOBMSG,XOBLINE
130 SET XOBLINE=$$POSTTXT^XOBSCAV(.XOBRET,.XOBMSG)
131 DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGON^XOBSCAV),";;",2),.XOBMSG,$$SUCCESS^XOBSCAV(),$PIECE($TEXT(SCHLGON^XOBSCAV),";;",2))
132 QUIT
133 ; ::AV.Logout.Request message processing
134LOGOUT ; logout
135 USE XOBNULL ; protect against direct writes to socket
136 ; do the logout
137 DO CLEAN
138 USE XOBPORT ; restore current IO (the TCP port)
139 NEW XOBMSG
140 DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGOUT^XOBSCAV),";;",2),.XOBMSG,$$SUCCESS^XOBSCAV(),$PIECE($TEXT(SCHSIMPL^XOBSCAV),";;",2))
141 QUIT
142 ; ::Logout to call if connection has timed out
143CLEAN ; logout
144 DO LOGOUT^XUSRB ; use of LOGOUT^XUSRB: DBIA #4054
145 QUIT
146 ; ::AV.SelectDivision.Request message processing
147DIVSLCT ; select division
148 NEW XOBRET
149 IF '+DUZ DO DIVSLCT0("User did not complete the access/verify code login process.") QUIT ; need DUZ
150 DO DIVSET^XUSRB2(.XOBRET,"`"_XOBDATA("XOB SECAV","SELECTEDDIVISION")) ; use of DIVSET^XUSRB2: DBIA #4055
151 IF +XOBRET DO QUIT
152 . DO DIVSLCT1
153 . DO DUZSV^XOBVSYSI(.DUZ)
154 DO DIVSLCT0("division not found for this user.")
155 QUIT
156 ;
157DIVSLCT0(XOBTEXT) ; send
158 NEW XOBMSG
159 SET XOBMSG(1)="<"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"_$$CHARCHK^XOBVLIB(XOBTEXT)_"</"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"
160 DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGSELDV^XOBSCAV),";;",2),.XOBMSG,$$FAILURE^XOBSCAV(),$PIECE($TEXT(SCHSIMPL^XOBSCAV),";;",2))
161 QUIT
162 ;
163DIVSLCT1 ; success
164 NEW XOBMSG
165 DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGSELDV^XOBSCAV),";;",2),.XOBMSG,$$SUCCESS^XOBSCAV(),$PIECE($TEXT(SCHSIMPL^XOBSCAV),";;",2))
166 QUIT
167 ;
168PRODMISM() ; returns 1 if production mismatch, 0 if not
169 IF XOBSYS("ENV")'="j2ee" QUIT 0 ; skip in c/s mode
170 SET XOBPROD=$SELECT($GET(XOBDATA("CLIENTISPRODUCTION"))="true":1,1:0)
171 IF '(XOBPROD=$$PROD^XUPROD(0)) QUIT 1
172 QUIT 0
173 ;
174STATMISM() ; return 1 if primary station mismatch, 0 if not
175 IF XOBSYS("ENV")'="j2ee" QUIT 0 ; no checking for c/s mode
176 NEW XOBSTAT
177 ; strip off suffix
178 SET XOBSTAT=$$STRPSUFF($GET(XOBDATA("CLIENTPRIMARYSTATION")))
179 ; compare w/KSP value
180 IF XOBSTAT'=XOBSYS("PRIMARY STATION#") QUIT 1 ;mismatch found
181 QUIT 0
182 ;
183STRPSUFF(XOBSTAT) ; strip alpha suffix from sta# e.g. AAC "200M"
184 SET XOBSTAT=+XOBSTAT
185 ; nursing home, treat 9 as suffix
186 IF $LENGTH(XOBSTAT)=4,$E(XOBSTAT,4)=9 SET XOBSTAT=$E(XOBSTAT,1,3)
187 QUIT XOBSTAT
188 ;
189ISCPROXY() ; c/proxy check
190 ; returns 1 if c/proxy user, 0 if not
191 NEW XOBCPCHK,XOBOK
192 SET XOBOK=1
193 SET XOBCPCHK=$$CPCHK^XUSAP(+XOBRET(0))
194 IF 'XOBCPCHK DO SET XOBOK=0
195 . DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Connector Proxy User Error",183008,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183008,$PIECE($GET(XOBCPCHK),U,2))))
196 QUIT XOBOK
197 ;
Note: See TracBrowser for help on using the repository browser.