| 1 | XUSBSE1 ;JLI/OAK-OIFO - MODIFICATIONS FOR BSE ;3/19/07 16:27
|
|---|
| 2 | ;;8.0;KERNEL;**404,439**;Jul 10, 1995;Build 12
|
|---|
| 3 | ; SETVISIT - returns a BSE token
|
|---|
| 4 | SETVISIT(RES) ; .RPC
|
|---|
| 5 | N TOKEN
|
|---|
| 6 | S TOKEN=$$HANDLE^XUSRB4("XUSBSE",1)
|
|---|
| 7 | S ^XTMP(TOKEN,1)=$$GET^XUESSO1(DUZ)
|
|---|
| 8 | S RES=TOKEN
|
|---|
| 9 | Q
|
|---|
| 10 | ;
|
|---|
| 11 | ; GETVISIT - returns demographics for user indicated by TOKEN
|
|---|
| 12 | ; output - RES - passed by reference, contains global location on return
|
|---|
| 13 | ; input - TOKEN - token value returned by remote site
|
|---|
| 14 | GETVISIT(RES,TOKEN) ; .RPC
|
|---|
| 15 | S RES=$G(^XTMP(TOKEN,1))
|
|---|
| 16 | K ^XTMP(TOKEN)
|
|---|
| 17 | Q
|
|---|
| 18 | ;
|
|---|
| 19 | RPUT(RET,VALUE) ;Put Token and data on new system
|
|---|
| 20 | S RET=1 ;Needs more work.
|
|---|
| 21 | Q
|
|---|
| 22 | ;
|
|---|
| 23 | OLDCAPRI(XWBUSRNM) ;The OLD CAPRI code, Remove next patch
|
|---|
| 24 | ; Return 1 if a valid user, else 0.
|
|---|
| 25 | N XVAL,XUCNTXT
|
|---|
| 26 | S XVAL=$$PUT^XUESSO1($P(XWBUSRNM,U,3,99)) ; Sign in as Visitor
|
|---|
| 27 | I XVAL D
|
|---|
| 28 | . S XUCNTXT=$$FIND1^DIC(19,"","X","DVBA CAPRI GUI")
|
|---|
| 29 | . D SETCNTXT(XUCNTXT)
|
|---|
| 30 | Q $S(XVAL>0:1,1:0)
|
|---|
| 31 | ;
|
|---|
| 32 | ; CHKUSER - determines if a BSE sign-on is valid
|
|---|
| 33 | ; INPUTSTR - input - String of characters from client
|
|---|
| 34 | ; return value - 1 if a valid user, else 0
|
|---|
| 35 | ; called from XUSRB
|
|---|
| 36 | CHKUSER(INPUTSTR) ;
|
|---|
| 37 | N XUCODE,XUENTRY,XUSTR,XUTOKEN
|
|---|
| 38 | I +INPUTSTR=-31,INPUTSTR["DVBA_",$$OLDCAPRI(INPUTSTR) Q 1
|
|---|
| 39 | I +INPUTSTR'=-35 Q 0
|
|---|
| 40 | S INPUTSTR=$P(INPUTSTR,U,2,99)
|
|---|
| 41 | K ^TMP("XUSBSE1",$J)
|
|---|
| 42 | S XUCODE=$$DECRYP^XUSRB1(INPUTSTR) ;TMP
|
|---|
| 43 | S XUCODE=$$EN^XUSHSH($P(XUCODE,U))
|
|---|
| 44 | S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE") D:XUENTRY>0
|
|---|
| 45 | . S XUTOKEN=$P($$DECRYP^XUSRB1(INPUTSTR),U,2)
|
|---|
| 46 | . S XUSTR=$P($$DECRYP^XUSRB1(INPUTSTR),U,3,4)
|
|---|
| 47 | . S XUENTRY=$$BSEUSER(XUENTRY,XUTOKEN,XUSTR)
|
|---|
| 48 | . Q
|
|---|
| 49 | Q $S(XUENTRY'>0:0,1:XUENTRY)
|
|---|
| 50 | ;
|
|---|
| 51 | ; BSEUSER - returns internal entry number for authenicated user or 0
|
|---|
| 52 | ; ENTRY - input - internal entry number in REMOTE APPLICATION file
|
|---|
| 53 | ; TOKEN - input - token from authenticaing site
|
|---|
| 54 | ; STR - input - remainder of input string (2 pieces)
|
|---|
| 55 | BSEUSER(ENTRY,TOKEN,STR) ;
|
|---|
| 56 | N XUIEN,XUCONTXT,XUDEMOG,XCNT,XVAL
|
|---|
| 57 | S XUIEN=0,XUDEMOG=""
|
|---|
| 58 | S XCNT=0 F S XCNT=$O(^XWB(8994.5,ENTRY,1,XCNT)) Q:XCNT'>0 S XVAL=^(XCNT,0) D Q:XUDEMOG'=""
|
|---|
| 59 | . ; INSERT CODE TO HANDLE CONNECTION TYPE AND CONNECTIONS
|
|---|
| 60 | . I $P(XVAL,U)="M" S XUDEMOG=$$M2M($P(XVAL,U,3),$P(XVAL,U,2),TOKEN) D CLOSE^XWBM2MC() Q
|
|---|
| 61 | . I $P(XVAL,U)="R" S XUDEMOG=$$XWB($P(XVAL,U,3),$P(XVAL,U,2),TOKEN) Q
|
|---|
| 62 | . I $P(XVAL,U)="H" S XUDEMOG=$$POST^XUSBSE2($P(XVAL,U,3),$P(XVAL,U,2),$P(XVAL,U,4),"xVAL="_TOKEN) Q
|
|---|
| 63 | . Q
|
|---|
| 64 | I XUDEMOG="" D
|
|---|
| 65 | . N SERVER,PORT
|
|---|
| 66 | . S XUDEMOG=""
|
|---|
| 67 | . S SERVER=$P(STR,U),PORT=$P(STR,U,2)
|
|---|
| 68 | . I SERVER'="",PORT>0 S XUDEMOG=$$GETDEMOG(SERVER,PORT,TOKEN)
|
|---|
| 69 | . Q
|
|---|
| 70 | I XUDEMOG'="" D
|
|---|
| 71 | . S XUCONTXT=$P($G(^XWB(8994.5,ENTRY,0)),U,2)
|
|---|
| 72 | . S XUIEN=$$SETUP(XUDEMOG,XUCONTXT)
|
|---|
| 73 | Q $S(XUIEN'>0:0,1:XUIEN)
|
|---|
| 74 | ;
|
|---|
| 75 | XWB(SERVER,PORT,TOKEN) ;Special Broker service
|
|---|
| 76 | N DEMOSTR,IO,XWBTDEV,XWBRBUF
|
|---|
| 77 | ;TEST CODE
|
|---|
| 78 | Q $$CALLBSE^XWBTCPM2(SERVER,PORT,TOKEN)
|
|---|
| 79 | ;
|
|---|
| 80 | M2M(SERVER,PORT,TOKEN) ;
|
|---|
| 81 | N DEMOGSTR,XWBCRLFL,RETRNVAL,XUSBSARR
|
|---|
| 82 | S DEMOGSTR=""
|
|---|
| 83 | N XWBSTAT,XWBPARMS,XWBTDEV,XWBNULL
|
|---|
| 84 | S XWBPARMS("ADDRESS")=SERVER,XWBPARMS("PORT")=PORT
|
|---|
| 85 | S XWBPARMS("RETRIES")=3 ;Retries 3 times to open
|
|---|
| 86 | ;
|
|---|
| 87 | I '$$OPEN^XWBRL(.XWBPARMS) Q "NO OPEN"
|
|---|
| 88 | S XWBPARMS("URI")="XUS GET VISITOR"
|
|---|
| 89 | D CLEARP^XWBM2MEZ
|
|---|
| 90 | D SETPARAM^XWBM2MEZ(1,"STRING",TOKEN)
|
|---|
| 91 | S XWBPARMS("URI")="XUS GET VISITOR"
|
|---|
| 92 | S XWBPARMS("RESULTS")=$NA(^TMP("XUSBSE1",$J))
|
|---|
| 93 | S XWBCRLFL=0
|
|---|
| 94 | D REQUEST^XWBRPCC(.XWBPARMS)
|
|---|
| 95 | I XWBCRLFL S RETRNVAL="XWBCRLFL IS TRUE" G M2MEXIT ; S @M2MLOC="XWBCRLFL IS TRUE" Q ; Q 0
|
|---|
| 96 | ;
|
|---|
| 97 | 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"
|
|---|
| 98 | D PARSE^XWBRPC(.XWBPARMS,"XUSBSARR") ;Parse out raw XML and place results in ^TMP("XWBM2MRPC"
|
|---|
| 99 | S RETRNVAL=$G(XUSBSARR(1))
|
|---|
| 100 | M2MEXIT ;
|
|---|
| 101 | D CLOSE^XWBM2MEZ
|
|---|
| 102 | Q RETRNVAL
|
|---|
| 103 | ;
|
|---|
| 104 | ; GETDEMOG - return value = string of demographic characteristics
|
|---|
| 105 | ; input SERVER - server address
|
|---|
| 106 | ; input PORT - port number for connection
|
|---|
| 107 | ; input TOKEN - token to identify user to authenticating server
|
|---|
| 108 | GETDEMOG(SERVER,PORT,TOKEN) ;
|
|---|
| 109 | N DEMOGSTR
|
|---|
| 110 | S DEMOGSTR=""
|
|---|
| 111 | Q DEMOGSTR
|
|---|
| 112 | ;
|
|---|
| 113 | ; SETUP - setup user as visitor, add context option
|
|---|
| 114 | ; return value = internal entry number for user, or 0
|
|---|
| 115 | ; input XUDEMOG - string of demographic characteristics
|
|---|
| 116 | ; input XUCONTXT - context option to be given to user
|
|---|
| 117 | SETUP(XUDEMOG,XUCONTXT) ;
|
|---|
| 118 | I '$$PUT^XUESSO1(XUDEMOG) Q 0
|
|---|
| 119 | I $G(DUZ)'>0 Q 0
|
|---|
| 120 | D SETCNTXT(XUCONTXT)
|
|---|
| 121 | Q DUZ
|
|---|
| 122 | ;
|
|---|
| 123 | SETCNTXT(XOPT) ;
|
|---|
| 124 | N OPT,XUCONTXT
|
|---|
| 125 | S XUCONTXT="`"_XOPT
|
|---|
| 126 | I $$FIND1^DIC(19,"","X",XUCONTXT)'>0 Q ; context option not in option file
|
|---|
| 127 | ;Have to use $D because of screen in 200.03 keeps FIND1^DIC from working.
|
|---|
| 128 | I '$D(^VA(200,DUZ,203,"B",XOPT)) D
|
|---|
| 129 | . ; Have to give the user a delegated option
|
|---|
| 130 | . N XARR S XARR(200.19,"+1,"_DUZ_",",.01)=XUCONTXT
|
|---|
| 131 | . D UPDATE^DIE("E","XARR")
|
|---|
| 132 | . ; And now she can give himself the context option
|
|---|
| 133 | . K XARR S XARR(200.03,"+1,"_DUZ_",",.01)=XUCONTXT
|
|---|
| 134 | . D UPDATE^DIE("E","XARR") ; Give context option as a secondary menu item
|
|---|
| 135 | . S ^XUTL("XQ",$J,"DUZ(BSE)")=XUCONTXT
|
|---|
| 136 | . ; But now we have to remove the delegated option
|
|---|
| 137 | . S OPT=$$FIND1^DIC(200.19,","_DUZ_",","X",XUCONTXT)
|
|---|
| 138 | . I OPT>0 D
|
|---|
| 139 | . . K XARR S XARR(200.19,(OPT_","_DUZ_","),.01)="@"
|
|---|
| 140 | . . D FILE^DIE("E","XARR")
|
|---|
| 141 | . . Q
|
|---|
| 142 | . Q
|
|---|
| 143 | Q
|
|---|
| 144 | ;
|
|---|
