145 lines
5.0 KiB
Mathematica
145 lines
5.0 KiB
Mathematica
XUSBSE1 ;JLI/OAK-OIFO - MODIFICATIONS FOR BSE ;3/19/07 16:27
|
|
;;8.0;KERNEL;**404,439**;Jul 10, 1995;Build 12
|
|
; SETVISIT - returns a BSE token
|
|
SETVISIT(RES) ; .RPC
|
|
N TOKEN
|
|
S TOKEN=$$HANDLE^XUSRB4("XUSBSE",1)
|
|
S ^XTMP(TOKEN,1)=$$GET^XUESSO1(DUZ)
|
|
S RES=TOKEN
|
|
Q
|
|
;
|
|
; GETVISIT - returns demographics for user indicated by TOKEN
|
|
; output - RES - passed by reference, contains global location on return
|
|
; input - TOKEN - token value returned by remote site
|
|
GETVISIT(RES,TOKEN) ; .RPC
|
|
S RES=$G(^XTMP(TOKEN,1))
|
|
K ^XTMP(TOKEN)
|
|
Q
|
|
;
|
|
RPUT(RET,VALUE) ;Put Token and data on new system
|
|
S RET=1 ;Needs more work.
|
|
Q
|
|
;
|
|
OLDCAPRI(XWBUSRNM) ;The OLD CAPRI code, Remove next patch
|
|
; Return 1 if a valid user, else 0.
|
|
N XVAL,XUCNTXT
|
|
S XVAL=$$PUT^XUESSO1($P(XWBUSRNM,U,3,99)) ; Sign in as Visitor
|
|
I XVAL D
|
|
. S XUCNTXT=$$FIND1^DIC(19,"","X","DVBA CAPRI GUI")
|
|
. D SETCNTXT(XUCNTXT)
|
|
Q $S(XVAL>0:1,1:0)
|
|
;
|
|
; CHKUSER - determines if a BSE sign-on is valid
|
|
; INPUTSTR - input - String of characters from client
|
|
; return value - 1 if a valid user, else 0
|
|
; called from XUSRB
|
|
CHKUSER(INPUTSTR) ;
|
|
N XUCODE,XUENTRY,XUSTR,XUTOKEN
|
|
I +INPUTSTR=-31,INPUTSTR["DVBA_",$$OLDCAPRI(INPUTSTR) Q 1
|
|
I +INPUTSTR'=-35 Q 0
|
|
S INPUTSTR=$P(INPUTSTR,U,2,99)
|
|
K ^TMP("XUSBSE1",$J)
|
|
S XUCODE=$$DECRYP^XUSRB1(INPUTSTR) ;TMP
|
|
S XUCODE=$$EN^XUSHSH($P(XUCODE,U))
|
|
S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE") D:XUENTRY>0
|
|
. S XUTOKEN=$P($$DECRYP^XUSRB1(INPUTSTR),U,2)
|
|
. S XUSTR=$P($$DECRYP^XUSRB1(INPUTSTR),U,3,4)
|
|
. S XUENTRY=$$BSEUSER(XUENTRY,XUTOKEN,XUSTR)
|
|
. Q
|
|
Q $S(XUENTRY'>0:0,1:XUENTRY)
|
|
;
|
|
; BSEUSER - returns internal entry number for authenicated user or 0
|
|
; ENTRY - input - internal entry number in REMOTE APPLICATION file
|
|
; TOKEN - input - token from authenticaing site
|
|
; STR - input - remainder of input string (2 pieces)
|
|
BSEUSER(ENTRY,TOKEN,STR) ;
|
|
N XUIEN,XUCONTXT,XUDEMOG,XCNT,XVAL
|
|
S XUIEN=0,XUDEMOG=""
|
|
S XCNT=0 F S XCNT=$O(^XWB(8994.5,ENTRY,1,XCNT)) Q:XCNT'>0 S XVAL=^(XCNT,0) D Q:XUDEMOG'=""
|
|
. ; INSERT CODE TO HANDLE CONNECTION TYPE AND CONNECTIONS
|
|
. I $P(XVAL,U)="M" S XUDEMOG=$$M2M($P(XVAL,U,3),$P(XVAL,U,2),TOKEN) D CLOSE^XWBM2MC() Q
|
|
. I $P(XVAL,U)="R" S XUDEMOG=$$XWB($P(XVAL,U,3),$P(XVAL,U,2),TOKEN) Q
|
|
. I $P(XVAL,U)="H" S XUDEMOG=$$POST^XUSBSE2($P(XVAL,U,3),$P(XVAL,U,2),$P(XVAL,U,4),"xVAL="_TOKEN) Q
|
|
. Q
|
|
I XUDEMOG="" D
|
|
. N SERVER,PORT
|
|
. S XUDEMOG=""
|
|
. S SERVER=$P(STR,U),PORT=$P(STR,U,2)
|
|
. I SERVER'="",PORT>0 S XUDEMOG=$$GETDEMOG(SERVER,PORT,TOKEN)
|
|
. Q
|
|
I XUDEMOG'="" D
|
|
. S XUCONTXT=$P($G(^XWB(8994.5,ENTRY,0)),U,2)
|
|
. S XUIEN=$$SETUP(XUDEMOG,XUCONTXT)
|
|
Q $S(XUIEN'>0:0,1:XUIEN)
|
|
;
|
|
XWB(SERVER,PORT,TOKEN) ;Special Broker service
|
|
N DEMOSTR,IO,XWBTDEV,XWBRBUF
|
|
;TEST CODE
|
|
Q $$CALLBSE^XWBTCPM2(SERVER,PORT,TOKEN)
|
|
;
|
|
M2M(SERVER,PORT,TOKEN) ;
|
|
N DEMOGSTR,XWBCRLFL,RETRNVAL,XUSBSARR
|
|
S DEMOGSTR=""
|
|
N XWBSTAT,XWBPARMS,XWBTDEV,XWBNULL
|
|
S XWBPARMS("ADDRESS")=SERVER,XWBPARMS("PORT")=PORT
|
|
S XWBPARMS("RETRIES")=3 ;Retries 3 times to open
|
|
;
|
|
I '$$OPEN^XWBRL(.XWBPARMS) Q "NO OPEN"
|
|
S XWBPARMS("URI")="XUS GET VISITOR"
|
|
D CLEARP^XWBM2MEZ
|
|
D SETPARAM^XWBM2MEZ(1,"STRING",TOKEN)
|
|
S XWBPARMS("URI")="XUS GET VISITOR"
|
|
S XWBPARMS("RESULTS")=$NA(^TMP("XUSBSE1",$J))
|
|
S XWBCRLFL=0
|
|
D REQUEST^XWBRPCC(.XWBPARMS)
|
|
I XWBCRLFL S RETRNVAL="XWBCRLFL IS TRUE" G M2MEXIT ; S @M2MLOC="XWBCRLFL IS TRUE" Q ; Q 0
|
|
;
|
|
I '$$EXECUTE^XWBVLC(.XWBPARMS) S RETRNVAL="FAILURE ON EXECUTE" G M2MEXIT ; S @M2MLOC="failure on execute" Q ;Run RPC and place raw XML results in ^TMP("XWBM2MVLC"
|
|
D PARSE^XWBRPC(.XWBPARMS,"XUSBSARR") ;Parse out raw XML and place results in ^TMP("XWBM2MRPC"
|
|
S RETRNVAL=$G(XUSBSARR(1))
|
|
M2MEXIT ;
|
|
D CLOSE^XWBM2MEZ
|
|
Q RETRNVAL
|
|
;
|
|
; GETDEMOG - return value = string of demographic characteristics
|
|
; input SERVER - server address
|
|
; input PORT - port number for connection
|
|
; input TOKEN - token to identify user to authenticating server
|
|
GETDEMOG(SERVER,PORT,TOKEN) ;
|
|
N DEMOGSTR
|
|
S DEMOGSTR=""
|
|
Q DEMOGSTR
|
|
;
|
|
; SETUP - setup user as visitor, add context option
|
|
; return value = internal entry number for user, or 0
|
|
; input XUDEMOG - string of demographic characteristics
|
|
; input XUCONTXT - context option to be given to user
|
|
SETUP(XUDEMOG,XUCONTXT) ;
|
|
I '$$PUT^XUESSO1(XUDEMOG) Q 0
|
|
I $G(DUZ)'>0 Q 0
|
|
D SETCNTXT(XUCONTXT)
|
|
Q DUZ
|
|
;
|
|
SETCNTXT(XOPT) ;
|
|
N OPT,XUCONTXT
|
|
S XUCONTXT="`"_XOPT
|
|
I $$FIND1^DIC(19,"","X",XUCONTXT)'>0 Q ; context option not in option file
|
|
;Have to use $D because of screen in 200.03 keeps FIND1^DIC from working.
|
|
I '$D(^VA(200,DUZ,203,"B",XOPT)) D
|
|
. ; Have to give the user a delegated option
|
|
. N XARR S XARR(200.19,"+1,"_DUZ_",",.01)=XUCONTXT
|
|
. D UPDATE^DIE("E","XARR")
|
|
. ; And now she can give himself the context option
|
|
. K XARR S XARR(200.03,"+1,"_DUZ_",",.01)=XUCONTXT
|
|
. D UPDATE^DIE("E","XARR") ; Give context option as a secondary menu item
|
|
. S ^XUTL("XQ",$J,"DUZ(BSE)")=XUCONTXT
|
|
. ; But now we have to remove the delegated option
|
|
. S OPT=$$FIND1^DIC(200.19,","_DUZ_",","X",XUCONTXT)
|
|
. I OPT>0 D
|
|
. . K XARR S XARR(200.19,(OPT_","_DUZ_","),.01)="@"
|
|
. . D FILE^DIE("E","XARR")
|
|
. . Q
|
|
. Q
|
|
Q
|
|
;
|