source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSRB.m@ 1141

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

initial load of WorldVistAEHR

File size: 5.8 KB
Line 
1XUSRB ;ISCSF/RWF - Request Broker ;3/13/07 09:56
2 ;;8.0;KERNEL;**11,16,28,32,59,70,82,109,115,165,150,180,213,234,238,265,337,395,404,437**;Jul 10, 1995;Build 2
3 Q ;No entry from top
4 ;
5 ;RPC BROKER calls, First parameter is always call-by-reference
6VALIDAV(RET,AVCODE) ;Check a users access
7 ;Return R(0)=DUZ, R(1)=(0=OK, 1,2...=Can't sign-on for some reason)
8 ; R(2)=verify needs changing, R(3)=Message, R(4)=0, R(5)=msg cnt, R(5+n)
9 ; R(R(5)+6)=# div user must select from, R(R(5)+6+n)=div
10 ;
11 N X,XUSER,XUNOW,XUDEV,XUM,XUMSG,%1,VCCH K DUZ
12 S U="^",RET(0)=0,RET(5)=0,XUF=$G(XUF,0),XUM=0,XUMSG=0,XUDEV=0
13 S DUZ=0,DUZ(0)="",VCCH=0 D NOW
14 S XOPT=$$STATE^XWBSEC("XUS XOPT")
15 S XUMSG=$$INHIBIT() I XUMSG S XUM=1 G VAX ;Logon inhibited
16 ;3 Strikes
17 I $$LKCHECK^XUSTZIP($G(IO("IP"))) S XUMSG=7 G VAX ;IP locked
18 ;Check type of sign-on code
19 I $L(AVCODE) D
20 . I $E(AVCODE,1,2)="~1" S DUZ=$$CHKASH^XUSRB4(AVCODE) Q
21 . I $E(AVCODE,1,2)="~2" S DUZ=$$CHKCCOW^XUSRB4(AVCODE) Q
22 . S DUZ=$$CHECKAV^XUS($$DECRYP^XUSRB1(AVCODE))
23 . Q
24 I DUZ'>0,$$FAIL^XUS3 D G VAX
25 . S XUM=1,XUMSG=7,X=$$RA^XUSTZ H 5 ;3 Strikes
26 S XUMSG=$$UVALID^XUS() G:XUMSG VAX ;Check User
27 S VCCH=$$VCVALID() ;Check VC
28 I DUZ>0 S XUMSG=$$POST(1)
29 I XUMSG>0 S DUZ=0,VCCH=0 ;If can't sign-on, don't tell need to change VC
30 I 'XUMSG,VCCH S XUMSG=12 D SET^XWBSEC("XUS DUZ",DUZ) ;Need to change VC
31VAX S:XUMSG>0 DUZ=0 ;Can't sign-on, Clear DUZ.
32 D:DUZ>0 POST2
33 S RET(0)=DUZ,RET(1)=XUM,RET(2)=VCCH,RET(3)=$S(XUMSG:$$TXT^XUS3(XUMSG),1:""),RET(4)=0
34 K DUZ("CCOW")
35 Q
36 ;
37NOW S U="^",XUNOW=$$NOW^XLFDT(),DT=$P(XUNOW,".")
38 Q
39 ;
40INTRO(RET) ;Return INTRO TEXT.
41 D INTRO^XUS1A("RET")
42 Q
43 ;
44VCVALID() ;Return 1 if the Verify code needs changing.
45 Q:'$G(DUZ) 1
46 Q:$P($G(^VA(200,DUZ,.1)),U,2)="" 1 ;VC is empty
47 Q:$P(^VA(200,DUZ,0),U,8)=1 0 ;VC never expires
48 N XUSER D USER^XUS(DUZ)
49 Q $$VCHG^XUS1
50 ;
51CVC(RET,XU1) ;change VC, Return 0 = success
52 N XU2,XU3,XU4 S DUZ=$G(DUZ),RET(0)=99,XU4=$$STATE^XWBSEC("XUS DUZ") S:(DUZ=0)&(XU4>0) DUZ=XU4 Q:DUZ'>0
53 S U="^",XU2=$P(XU1,U,2),XU3=$P(XU1,U,3),XU1=$P(XU1,U)
54 S XU1=$$DECRYP^XUSRB1(XU1),XU2=$$DECRYP^XUSRB1(XU2),XU3=$$DECRYP^XUSRB1(XU3)
55 S XU3=$$BRCVC^XUS2(XU1,XU2),RET(0)=+XU3,RET(1)=$P(XU3,U,2,9)
56 I XU3>0 S DUZ=0 ;Clean-up if not changed.
57 I 'XU3,XU4 D KILL^XWBSEC("XUS DUZ"),POST2
58 Q
59 ;
60SHOWPOST() ;EF. Check if should send the POST SIGN-ON msg.
61 Q +$P($G(^XTV(8989.3,1,"XWB")),"^",2)
62 ;
63POST(CVC) ;Finish setup partition, I CVC don't log yet
64 N X,XUM,XUDIV S:$D(IO)[0 IO=$I S IO(0)=IO
65 K ^UTILITY($J),^TMP($J)
66 I '$D(XUSER(0)),DUZ D USER^XUS(DUZ)
67 S XUM=$$USER^XUS1A Q:XUM>0 XUM ;User can't sign on for some reason.
68 S RET(5)=0 ;The next line sends the post sign-on msg
69 F %=1:1 Q:'$D(XUTEXT(%)) S RET(5+%)=$E(XUTEXT(%),2,256),RET(5)=%
70 I '$$SHOWPOST S RET(5)=0 ;This line stops the sending/display of the msg.
71 D:'$G(CVC) POST2
72 Q 0
73 ;
74POST2 D:'$D(XUNOW) NOW
75 D DUZ^XUS1A,SAVE^XUS1,LOG^XUS1,ABT^XQ12
76 D KILL^XWBSEC("XUS XOPT"),CLRFAC^XUS3($G(IO("IP"))) ;p265
77 I $T(SETTIME^XWBTCPC)]"" D SETTIME^XWBTCPC() ;Clear sign-on time-out
78 K:$G(XWBVER)<1.106 XQY,XQY0 ;Delete the sign-on context.
79 K XUTEXT,XOPT,XUEON,XUEOFF,XUTT,XUDEV,XUSER
80 Q
81 ;
82INHIBIT() ;Is Logon to this system Inhibited?
83 I $$INHIB1() Q 1
84 I $$INHIB2() Q 2
85 Q 0
86 ;
87INHIB1() ;The LOGON check
88 I $G(^%ZIS(14.5,"LOGON",XQVOL)) Q 1
89 Q 0
90 ;
91INHIB2() ;The Max User Check
92 I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(XUVOL,U,3),($P(XUVOL,U,3)'>Y) Q 2
93 Q 0
94 ;
95LOGOUT ;Finish logout of user.
96 N XU1
97 D CLEARALL^XWBDRPC(.XU1)
98 ;Remove CCOW sign-on data
99 S HDL=$G(^XUTL("XQ",$J,"HDL")) I $L(HDL) D
100 . K ^XTMP(HDL,"JOB",$J)
101 . I $O(^XTMP(HDL,"JOB",0))="" K ^XTMP(HDL)
102 ;
103 D BYE^XUSCLEAN,XUTL^XUSCLEAN ;Mark the sign-on log, File cleanup.
104 Q
105 ;D1,D2 are place holders for now
106SETUP(RET,XWBUSRNM,ASOSKIP,D2) ;sets up environment for GUI signon
107 K DUZ
108 S XWBUSRNM=$G(XWBUSRNM),ASOSKIP=$G(ASOSKIP)
109 I $L($G(XWBTIP)) S IO("IP")=XWBTIP
110 S IO("CLNM")=$$LOW^XLFSTR($G(XWBCLMAN)) D ZIO^%ZIS4
111 ;Setup needed variables
112 D SET1^XUS(0),SET^XWBSEC("XUS XOPT",XOPT) ;p265
113 ;I '$D(IO("HOME")) S %ZIS="0H",IOP="NULL" D ^%ZIS ;Setup NULL as the home device
114 D SAVE^XUS1 ;save the home device
115 ;0=server name, 1=volume, 2=uci, 3=device, 4=# attempts, 5=skip signon-screen,6=Domain Name, 7=Production (0=no, 1=Yes)
116 S RET(0)=$P(XUENV,U,3),RET(1)=$P(XUVOL,U),RET(2)=XUCI
117 S RET(3)=$I,RET(4)=$P(XOPT,U,2),RET(5)=0
118 S RET(6)=$G(^XMB("NETNAME")) ;DBIA #1131
119 S RET(7)=$$PROD^XUPROD ;Tell if production.
120 I $$INHIBIT() Q
121 ; Code for DBA Capri Type Program
122 I (+XWBUSRNM<-30),$$CHKUSER^XUSBSE1(XWBUSRNM) S RET(5)=1 Q ; BSE CHANGE
123 ; End of Code for DBA Capri Program
124 ;Auto sign-on check only for Broker v1.1
125 I $G(ASOSKIP) S XQXFLG("ASO")=1 ;Skip the ASO check
126 I $G(XWBVER)<1.1 S XQXFLG("ZEBRA")=-1 ;Disable for v1.0
127 I $L(IO("CLNM")) S DUZ=$$AUTOXWB^XUS1B() ;Only check when 1.1 CL.
128 I DUZ>0 D NOW S XUMSG=$$POST(0) I XUMSG>0 S DUZ=0
129 S:DUZ>0 RET(5)=1
130 Q
131 ;
132OWNSKEY(RET,LIST,IEN) ;Does user have Key
133 N I,K S I=""
134 I $G(IEN)'>0 S IEN=$G(DUZ)
135 I $G(IEN)'>0 S RET(0)=0 Q
136 I $O(LIST(""))="" S RET(0)=$$KCHK(LIST,IEN) Q
137 F S I=$O(LIST(I)) Q:I="" S RET(I)=$$KCHK(LIST(I),IEN)
138 Q
139 ;
140KCHK(%,IEN) ;Key Check
141 S:$G(IEN)'>0 IEN=$G(DUZ) Q $S($G(IEN)>0:$D(^XUSEC(%,IEN)),1:0)
142 ;
143ALLKEYS(RET,IEN,FLG) ;Return ALL or most KEYS that a user has.
144 N I,J,K,L K ^TMP("XU",$J)
145 S RET=$NA(^TMP("XU",$J))
146 S:'$D(IEN) IEN=DUZ I IEN'>0 S @RET@(0)=-1 Q
147 S I=0,L=0
148 F S I=$O(^VA(200,IEN,51,I)) Q:I'>0 S K=$G(^DIC(19.1,I,0)) D
149 . Q:'$P(K,U,5) ;Check 'Send to J2EE' field.
150 . S L=L+1,@RET@(L,0)=$P(K,U,1)
151 . Q
152 Q
153 ;
154AVHELP(RET) ; send access/verify code instructions.
155 S RET(0)=$$AVHLPTXT^XUS2()
156 Q
157 ;
158OPTACCES(RET,USER,OPTIONS,MODE) ;Checks or sets user's access for passed in options
159 S MODE="CHECK" ;only CHECK mode supported for now
160 N I S I=""
161 I $G(USER)'>0 S RET(0)=0 Q
162 F S I=$O(OPTIONS(I)) Q:I="" S RET(I)=$$CHK^XQCS(USER,OPTIONS(I))=1
163 Q
164 ;
165CHECKAV(AVC) ;SR. EF. to check an A/V code, Separate w/ ";", return IEN or 0
166 N XUF,XUSER S XUF=0,U="^"
167 Q $$CHECKAV^XUS(AVC)
Note: See TracBrowser for help on using the repository browser.