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/XUSBSE1.m@ 1046

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

initial load of WorldVistAEHR
File size: 5.0 KB
RevLine 
[613]1XUSBSE1 ;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
4SETVISIT(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
14GETVISIT(RES,TOKEN) ; .RPC
15 S RES=$G(^XTMP(TOKEN,1))
16 K ^XTMP(TOKEN)
17 Q
18 ;
19RPUT(RET,VALUE) ;Put Token and data on new system
20 S RET=1 ;Needs more work.
21 Q
22 ;
23OLDCAPRI(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
36CHKUSER(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)
55BSEUSER(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 ;
75XWB(SERVER,PORT,TOKEN) ;Special Broker service
76 N DEMOSTR,IO,XWBTDEV,XWBRBUF
77 ;TEST CODE
78 Q $$CALLBSE^XWBTCPM2(SERVER,PORT,TOKEN)
79 ;
80M2M(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))
100M2MEXIT ;
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
108GETDEMOG(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
117SETUP(XUDEMOG,XUCONTXT) ;
118 I '$$PUT^XUESSO1(XUDEMOG) Q 0
119 I $G(DUZ)'>0 Q 0
120 D SETCNTXT(XUCONTXT)
121 Q DUZ
122 ;
123SETCNTXT(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 ;
Note: See TracBrowser for help on using the repository browser.