Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUSRB

XUSRB.m

Go to the documentation of this file.
  1. XUSRB ;ISCSF/RWF - Request Broker ;12/01/15 07:54
  1. ;;8.0;KERNEL;**11,16,28,32,59,70,82,109,115,165,150,180,213,234,238,265,337,395,404,437,523,659**;Jul 10, 1995;Build 22
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. Q ;No entry from top
  1. ;
  1. ;RPC BROKER calls, First parameter is always call-by-reference
  1. VALIDAV(RET,AVCODE) ;RPC. XUS CVC - IA #6296
  1. ;Check a users access
  1. ;Return R(0)=DUZ, R(1)=(0=OK, 1,2...=Can't sign-on for some reason)
  1. ; R(2)=verify needs changing, R(3)=Message, R(4)=0, R(5)=msg cnt, R(5+n)
  1. ; R(R(5)+6)=# div user must select from, R(R(5)+6+n)=div
  1. ;
  1. N X,XUSER,XUNOW,XUDEV,XUM,XUMSG,%1,VCCH K DUZ
  1. S U="^",RET(0)=0,RET(5)=0,XUF=$G(XUF,0),XUM=0,XUMSG=0,XUDEV=0
  1. S DUZ=0,DUZ(0)="",VCCH=0 D NOW
  1. S XOPT=$$STATE^XWBSEC("XUS XOPT")
  1. S XUMSG=$$INHIBIT() I XUMSG S XUM=1 G VAX ;Logon inhibited
  1. ;3 Strikes
  1. I $$LKCHECK^XUSTZIP($G(IO("IP"))) S XUMSG=7 G VAX ;IP locked
  1. ;Check type of sign-on code
  1. I $L(AVCODE) D
  1. . I $E(AVCODE,1,2)="~1" S DUZ=$$CHKASH^XUSRB4(AVCODE),DUZ("AUTHENTICATION")="ASHTOKEN" Q
  1. . I $E(AVCODE,1,2)="~2" S DUZ=$$CHKCCOW^XUSRB4(AVCODE),DUZ("AUTHENTICATION")="CCOWTOKEN" Q
  1. . S DUZ=$$CHECKAV^XUS($$DECRYP^XUSRB1(AVCODE)),DUZ("AUTHENTICATION")="AVCODES"
  1. . Q
  1. I DUZ'>0,$$FAIL^XUS3 D G VAX
  1. . S XUM=1,XUMSG=7,X=$$RA^XUSTZ H 5 ;3 Strikes
  1. S XUMSG=$$UVALID^XUS() G:XUMSG VAX ;Check User
  1. S VCCH=$$VCVALID() ;Check VC
  1. I $G(DUZ("LOA"))="" S DUZ("LOA")=2
  1. I DUZ>0 S XUMSG=$$POST(1)
  1. I XUMSG>0 S DUZ=0,VCCH=0 ;If can't sign-on, don't tell need to change VC
  1. I 'XUMSG,VCCH S XUMSG=12 D SET^XWBSEC("XUS DUZ",DUZ) ;Need to change VC
  1. VAX S:XUMSG>0 DUZ=0 ;Can't sign-on, Clear DUZ.
  1. I DUZ>0 D
  1. . S DUZ("LOA")=2
  1. . D POST2
  1. S RET(0)=DUZ,RET(1)=XUM,RET(2)=VCCH,RET(3)=$S(XUMSG:$$TXT^XUS3(XUMSG),1:""),RET(4)=0
  1. K DUZ("CCOW")
  1. Q
  1. ;
  1. NOW S U="^",XUNOW=$$NOW^XLFDT(),DT=$P(XUNOW,".")
  1. Q
  1. ;
  1. INTRO(RET) ;Return INTRO TEXT.
  1. D INTRO^XUS1A("RET")
  1. Q
  1. ;
  1. VCVALID() ;Return 1 if the Verify code needs changing.
  1. Q:'$G(DUZ) 1
  1. Q:$P($G(^VA(200,DUZ,.1)),U,2)="" 1 ;VC is empty
  1. Q:$P(^VA(200,DUZ,0),U,8)=1 0 ;VC never expires
  1. N XUSER D USER^XUS(DUZ)
  1. Q $$VCHG^XUS1
  1. ;
  1. CVC(RET,XU1) ;change VC, Return 0 = success
  1. 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
  1. S U="^",XU2=$P(XU1,U,2),XU3=$P(XU1,U,3),XU1=$P(XU1,U)
  1. S XU1=$$DECRYP^XUSRB1(XU1),XU2=$$DECRYP^XUSRB1(XU2),XU3=$$DECRYP^XUSRB1(XU3)
  1. S XU3=$$BRCVC^XUS2(XU1,XU2),RET(0)=+XU3,RET(1)=$P(XU3,U,2,9)
  1. I XU3>0 S DUZ=0 ;Clean-up if not changed.
  1. I 'XU3,XU4 D KILL^XWBSEC("XUS DUZ"),POST2
  1. Q
  1. ;
  1. SHOWPOST() ;EF. Check if should send the POST SIGN-ON msg.
  1. Q +$P($G(^XTV(8989.3,1,"XWB")),"^",2)
  1. ;
  1. POST(CVC) ;Finish setup partition, I CVC don't log yet
  1. N X,XUM,XUDIV S:$D(IO)[0 IO=$I S IO(0)=IO
  1. K ^UTILITY($J),^TMP($J)
  1. I '$D(XUSER(0)),DUZ D USER^XUS(DUZ)
  1. S XUM=$$USER^XUS1A Q:XUM>0 XUM ;User can't sign on for some reason.
  1. S RET(5)=0 ;The next line sends the post sign-on msg
  1. F %=1:1 Q:'$D(XUTEXT(%)) S RET(5+%)=$E(XUTEXT(%),2,256),RET(5)=%
  1. I '$$SHOWPOST S RET(5)=0 ;This line stops the sending/display of the msg.
  1. D:'$G(CVC) POST2
  1. Q 0
  1. ;
  1. POST2 ;Finish User Setup for silent log-on
  1. D:'$D(XUNOW) NOW
  1. D DUZ^XUS1A,SAVE^XUS1,LOG^XUS1,ABT^XQ12
  1. D KILL^XWBSEC("XUS XOPT"),CLRFAC^XUS3($G(IO("IP"))) ;p265
  1. D SETTIME^XWBTCPM() ;Set normal Broker time-out
  1. S DTIME=$$DTIME^XUP(DUZ) ;See DTIME set for user
  1. K:$G(XWBVER)<1.106 XQY,XQY0 ;Delete the sign-on context.
  1. K XUTEXT,XOPT,XUEON,XUEOFF,XUTT,XUDEV,XUSER
  1. Q
  1. ;
  1. INHIBIT() ;Is Logon to this system Inhibited?
  1. I $$INHIB1() Q 1
  1. I $$INHIB2() Q 2
  1. Q 0
  1. ;
  1. INHIB1() ;The LOGON check
  1. I $G(^%ZIS(14.5,"LOGON",XQVOL)) Q 1
  1. Q 0
  1. ;
  1. INHIB2() ;The Max User Check
  1. I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(XUVOL,U,3),($P(XUVOL,U,3)'>Y) Q 2
  1. Q 0
  1. ;
  1. LOGOUT ;Finish logout of user.
  1. N XU1
  1. D CLEARALL^XWBDRPC(.XU1)
  1. ;Remove CCOW sign-on data
  1. S HDL=$G(^XUTL("XQ",$J,"HDL")) I $L(HDL) D
  1. . K ^XTMP(HDL,"JOB",$J)
  1. . I $O(^XTMP(HDL,"JOB",0))="" K ^XTMP(HDL)
  1. ;
  1. D BYE^XUSCLEAN,XUTL^XUSCLEAN ;Mark the sign-on log, File cleanup.
  1. Q
  1. ;D1,D2 are place holders for now
  1. SETUP(RET,XWBUSRNM,ASOSKIP,D2) ;RPC. XUS SIGNON SETUP - IA #1632 (API IA #4054)
  1. ;sets up environment for GUI signon
  1. N X1 K DUZ
  1. S XWBUSRNM=$G(XWBUSRNM),ASOSKIP=$G(ASOSKIP)
  1. I $L($G(XWBTIP)) S IO("IP")=XWBTIP
  1. S IO("CLNM")=$$LOW^XLFSTR($G(XWBCLMAN)) D ZIO^%ZIS4
  1. ;Setup needed variables
  1. D SET1^XUS(0),SET^XWBSEC("XUS XOPT",XOPT) ;p265
  1. ;I '$D(IO("HOME")) S %ZIS="0H",IOP="NULL" D ^%ZIS ;Setup NULL as the home device
  1. D SAVE^XUS1 ;save the home device
  1. ;0=server name, 1=volume, 2=uci, 3=device, 4=# attempts, 5=skip signon-screen,6=Domain Name, 7=Production (0=no, 1=Yes)
  1. S RET(0)=$P(XUENV,U,3),RET(1)=$P(XUVOL,U),RET(2)=XUCI
  1. S RET(3)=$I,RET(4)=$P(XOPT,U,2),RET(5)=0
  1. S RET(6)=$G(^XMB("NETNAME")) ;DBIA #1131
  1. S RET(7)=$$PROD^XUPROD ;Tell if production.
  1. S X1=$$INHIBIT() I X1 S XWBERR=$S(X1=1:"Logons Inhibited",1:"Max Users") Q ;p523
  1. ; Check for Broker Security Enhancement (BSE) token
  1. I (+XWBUSRNM<-30),$$CHKUSER^XUSBSE1(XWBUSRNM) S RET(5)=1 D POST2 Q ;p523 BSE CHANGE
  1. ; End of Check for BSE token
  1. ;Auto sign-on check only for Broker v1.1
  1. I $G(ASOSKIP) S XQXFLG("ASO")=1 ;Skip the ASO check, Not for VISITORS p523
  1. I $G(XWBVER)<1.1 S XQXFLG("ZEBRA")=-1 ;Disable for v1.0
  1. I $L(IO("CLNM")),'$G(DUZ) S DUZ=$$AUTOXWB^XUS1B() ;Only check when 1.1 CL.
  1. I $G(DUZ)>0 D ;p523
  1. . I '$D(XUSER(0)),DUZ D USER^XUS(DUZ)
  1. . N %T S %T=$$USER^XUS1A I %T S DUZ=0 Q
  1. . D NOW,POST2 S RET(5)=1
  1. Q
  1. ;
  1. OWNSKEY(RET,LIST,IEN) ;RPC. XUS KEY CHECK - IA #6286 (API IA #3277)
  1. ;Does user have Security Key?
  1. N I,K S I=""
  1. I $G(IEN)'>0 S IEN=$G(DUZ)
  1. I $G(IEN)'>0 S RET(0)=0 Q
  1. I $O(LIST(""))="" S RET(0)=$$KCHK(LIST,IEN) Q
  1. F S I=$O(LIST(I)) Q:I="" S RET(I)=$$KCHK(LIST(I),IEN)
  1. Q
  1. ;
  1. KCHK(%,IEN) ;Key Check
  1. S:$G(IEN)'>0 IEN=$G(DUZ) Q $S($G(IEN)>0:$D(^XUSEC(%,IEN)),1:0)
  1. ;
  1. ALLKEYS(RET,IEN,FLG) ;RPC. XUS ALLKEYS - IA #6287 (API IA #3277)
  1. ;Return ALL or most KEYS that a user has.
  1. N I,J,K,L K ^TMP("XU",$J)
  1. S RET=$NA(^TMP("XU",$J))
  1. S:'$D(IEN) IEN=DUZ I IEN'>0 S @RET@(0)=-1 Q
  1. S I=0,L=0
  1. F S I=$O(^VA(200,IEN,51,I)) Q:I'>0 S K=$G(^DIC(19.1,I,0)) D
  1. . Q:'$P(K,U,5) ;Check 'Send to J2EE' field.
  1. . S L=L+1,@RET@(L,0)=$P(K,U,1)
  1. . Q
  1. Q
  1. ;
  1. AVHELP(RET) ; send access/verify code instructions.
  1. S RET(0)=$$AVHLPTXT^XUS2()
  1. Q
  1. ;
  1. OPTACCES(RET,USER,OPTIONS,MODE) ;Checks or sets user's access for passed in options
  1. S MODE="CHECK" ;only CHECK mode supported for now
  1. N I S I=""
  1. I $G(USER)'>0 S RET(0)=0 Q
  1. F S I=$O(OPTIONS(I)) Q:I="" S RET(I)=$$CHK^XQCS(USER,OPTIONS(I))=1
  1. Q
  1. ;
  1. CHECKAV(AVC) ;SR. EF. to check an A/V code, Separate w/ ";", return IEN or 0
  1. N XUF,XUSER S XUF=0,U="^"
  1. Q $$CHECKAV^XUS(AVC)