source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUESSO1.m@ 1569

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

initial load of FOIAVistA 6/30/08 version

File size: 5.5 KB
Line 
1XUESSO1 ;LUKE/SEA Single Sign-on utilities; ;08/08/2005 09:58
2 ;;8.0;KERNEL;**165,183,196,245,254,269,337,395**;Jul 10, 1995;Build 4
3 ;
4GET(INDUZ) ;Gather identifying data from user's home site.
5 ;Must have Name, Access&Verify codes, SSN (no pseudo), station name&number
6 N %,NAME,SITE,SSN,PHONE,X,N,VPID
7 I '$D(DUZ) G BOMB
8 I '$D(DUZ(2)) G BOMB
9 I '$D(INDUZ) S INDUZ=DUZ
10 S N=$G(^VA(200,DUZ,0))
11 I '$L(N) G BOMB
12 S %=$P(N,U,3) I $L(%)<1 G BOMB ;No Access Code
13 S %=$P($G(^VA(200,INDUZ,.1)),U,2) I $L(%)<1 G BOMB ;No Verify Code
14 S %=$P(N,U,11) I $L(%)>1,(DT>%) G BOMB ;Terminated
15 S NAME=$P(N,U)
16 I '$L(NAME) G BOMB
17 ;
18 S SITE=$$NS^XUAF4(DUZ(2)) ;Site is name^station#
19 I $P(SITE,U,2)="" G BOMB ;Need a station number
20 ;
21 S SSN=$P($G(^VA(200,DUZ,1)),U,9)
22 I $$SPECIAL($P(SITE,"^",2)) S SSN=999999999 G G4 ;Manila RO doesn't need SSN
23 I 'SSN G BOMB
24 ;Don't allow if the SSN is pseudo
25 I $E(SSN,10)="P" G BOMB
26 ;Don't allow if the SSN is not real, (e.g. 00000NNNN)
27 I $E(SSN,1,5)="00000" G BOMB
28 ;
29G4 S PHONE=$$PH
30 S VPID=$$VPID^XUPS(DUZ) ;(p337)
31 S X=SSN_U_NAME_U_SITE_U_DUZ
32 I $L(PHONE)>2&($L(PHONE<20)) S X=X_U_PHONE
33 S $P(X,U,7)=VPID ;(p337)
34 ;ssn^name^station name^station number^DUZ^phone^vpid
35 Q X
36 ;
37 ;
38BOMB ;Insufficient information to allow visiting
39 S X="-1^Insufficient User Information On File. ssn,name,station name,station number,DUZ"
40 Q X
41 ;
42 ;
43PH() ; Try for a phone number or pager
44 N %,X
45 S %=""
46 S X=$G(^VA(200,DUZ,.13))
47 I '$L(X) Q ""
48 ;
49 S %=$P(X,U,5) I $L(%)>6 Q % ;Commercial #
50 S %=$P(X,U,2) I $L(%)>2 Q % ;Office
51 S %=$P(X,U,8) I $L(%)>6 Q % ;Digital Pager
52 S %=$P(X,U,7) I $L(%)>6 Q % ;Pager
53 S %=$P(X,U,3) I $L(%)>2 Q % ;Phone #3
54 S %=$P(X,U,4) I $L(%)>2 Q % ;Phone #4
55 S %=$P(X,U,1) I $L(%)>2 Q % ;Home Phone
56 Q "" ;Couldn't find one.
57 ;
58SPECIAL(SN) ;Special Manila RO site
59 Q 358=SN
60 ;
61 ;
62PUT(DATIN) ;;Setup data from authenticating site GET() at receiving site
63 ;Return: 0=fail, 1=OK
64 N NEWDUZ,FDR,TODAY,IEN,DIC,USER,X,%T
65 N SSN,NAME,SITE,SITENUM,RMTDUZ,PHONE,VPID
66 S TODAY=$$HTFM^XLFDT($H),DT=$P(TODAY,"."),U="^"
67 S NEWDUZ=0
68 K ^TMP("DIERR",$J)
69 ;
70 S SSN=$P(DATIN,U,1)
71 S NAME=$P(DATIN,U,2)
72 S SITE=$P(DATIN,U,3)
73 S SITENUM=$P(DATIN,U,4)
74 S RMTDUZ=$P(DATIN,U,5)
75 S PHONE=$P(DATIN,U,6)
76 S VPID=$P(DATIN,U,7) ;(p337)
77 ;Format checks
78 I NAME'?1U.E1","1U.E Q 0
79 I SSN'?9N Q 0
80 I '$L(SITE)!('$L(SITENUM)) Q 0
81 I RMTDUZ'>0 Q 0 ;p337
82 ;
83 ;Get a LOCK. Block if can't get.
84 L +^VA(200,"HL7"):10 Q:'$T 0
85 S %T=$$TALL() L -^VA(200,"HL7")
86 I %T Q $$SET(NEWDUZ) ;Return 1 if OK.
87 Q 0
88 ;
89TALL() ;Test for existing user or adds a new one
90 N DUZ,FLAG S FLAG=0,DUZ=0,DUZ(0)=""
91 ;See if the SSN is in the NPF cross reference
92 I '$$SPECIAL(SITENUM),$D(^VA(200,"SSN",SSN)) D
93 .S NEWDUZ=$O(^VA(200,"SSN",SSN,0))
94 .I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
95 .D ADDV ;Add VPID if don't have one (p337)
96 .D UPDT
97 .S FLAG=1
98 .Q
99 ;See if in the AVISIT cross reference
100 I 'FLAG,$$SPECIAL(SITENUM) D
101 . S NEWDUZ=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0))
102 . Q:NEWDUZ'>0
103 . D UPDT S FLAG=1
104 . Q
105 I FLAG Q 1 ;Quit here if we found a match for SSN or AVISIT
106 ;
107 ;
108 ;There is no matching SSN, try for a NAME match in "B"
109 S FLAG=0,NAME=$$UP^XLFSTR(NAME)
110 I $D(^VA(200,"B",NAME)) D
111 .N %,USER,USER2
112 .S NEWDUZ=$O(^VA(200,"B",NAME,0))
113 .S USER2=$O(^VA(200,"B",NAME,NEWDUZ)) ;More then one?
114 .Q:$L(USER2)>0
115 .;
116 .S %=$P($G(^VA(200,NEWDUZ,1)),U,9)
117 .Q:%'=SSN ;Don't use this name if it has a different SSN
118 .;
119 .I '$L($P(^VA(200,NEWDUZ,1),U,9)) D ADDS
120 .I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
121 .D UPDT S FLAG=1
122 .Q
123 I FLAG Q 1 ;Quit here if we found an exact match for NAME (w/o SSN)
124 ;
125NEWU ;We didn't find anybody under SSN or NAME so we add a new user
126 ;
127 S DIC(0)="" ;Turn off ^XUA4A7 (work around)
128 ;
129 ;Put the name in the .01 field first.
130 D ADDU ;ADDU will set NEWDUZ
131 ;If NEWDUZ is still 0, the User add didn't work so exit.
132 I NEWDUZ=0 Q 0
133 ; Add SSN and Alias and VPID
134 D ADDS,ADDA,ADDV ;(p337)
135 ; Fill in the VISITED FROM multiple
136 D VISM,UPDT ;Do update for all data in UPDT
137 ;
138 I $D(^TMP("DIERR",$J)) Q 0 ;W !!,"=========> FileMan Error",!!
139 ;
140 I NEWDUZ D BULL Q 1 ;Every thing OK
141 Q 0 ;Couldn't add user
142 ;
143 ;
144 ; *****Subroutines*****
145 ;
146 ;
147SET(NEWDUZ) ;Set the user up to go
148 Q:NEWDUZ'>0 0
149 N XUSER,XOPT
150 S DUZ=NEWDUZ,U="^"
151 D DUZ^XUS1A
152 Q 1
153 ;
154ADDU ;Add a new name to the New Person File
155 N DD,DO,DIC,DA,X,Y
156 S DIC="^VA(200,",DIC(0)="L",X=NAME
157 D FILE^DICN
158 S:Y>0 NEWDUZ=+Y
159 Q
160 ;
161ADDS ;Add a SSN to the file
162 Q:$$SPECIAL(SITENUM)
163 S IEN=NEWDUZ_","
164 S FDR(200,IEN,9)=SSN
165 ;Do update for all data in UPDT
166 Q
167 ;
168ADDA ;Add a new Alias to file 200.04
169 Q:$D(^VA(200,NEWDUZ,3,"B","VISITOR"))
170 S IEN="+2,"_NEWDUZ_","
171 S FDR("200.04",IEN,.01)="VISITOR"
172 ;Do update for all data in UPDT
173 Q
174 ;
175ADDV ;Add a VPID to the file (p337)
176 Q:'$L(VPID)
177 I $$IEN^XUPS(VPID)>0 Q ;VPID in use.
178 S FDR(200,NEWDUZ_",",9000)=VPID
179 Q
180 ;
181VISM ;Create a multiple for this site number in the VISTED FROM file
182 ;K IEN,FDR
183 S IEN="+3,"_NEWDUZ_","
184 S FDR("200.06",IEN,.01)=SITENUM
185 ;
186 S FDR("200.06",IEN,1)=SITE
187 S FDR("200.06",IEN,2)=RMTDUZ
188 S FDR("200.06",IEN,3)=TODAY
189 I $D(PHONE),($L(PHONE)>2) S FDR("200.06",IEN,5)=PHONE
190 ;Do update for all data in UPDT
191 Q
192 ;
193UPDT ;Update the LAST VISIT field
194 I $D(FDR(200.06)) S IEN=$O(FDR(200.06,""))
195 E S IEN=$O(^VA(200,NEWDUZ,8910,"B",SITENUM,0))_","_NEWDUZ_","
196 S FDR(200.06,IEN,4)=TODAY
197 K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
198 Q
199 ;
200BULL ;Set up the bulletin and fire it off, Let MM see if bulletin is there
201 N XMB
202 S XMB="XUVISIT"
203 S XMB(1)=$$FMTE^XLFDT(TODAY)
204 S XMB(2)=NAME
205 S XMB(3)=NEWDUZ
206 S XMB(4)=SITE
207 S XMB(5)=SITENUM
208 S XMB(6)=RMTDUZ
209 S XMB(7)=PHONE
210 D ^XMB
211 Q
Note: See TracBrowser for help on using the repository browser.