source: cprs/branches/tmg-cprs/m_files/TMGXUS2.m@ 872

Last change on this file since 872 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload

File size: 7.3 KB
Line 
1TMGXUS2 ;TMG/kst/Altered version of XUS2 ;03/25/06
2 ;;1.0;TMG-LIB;**1**;12/23/05
3
4XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;07/15/2003 12:20
5 ;;8.0;KERNEL;**59,180,313**;Jul 10, 1995
6 G XUS2^XUVERIFY ;All check or return user attributes moved to XUVERIFY
7USER G USER^XUVERIFY
8EDIT G EDIT^XUVERIFY
9 Q
10 ;
11ACCED ; ACCESS CODE EDIT from DD
12 N DIR,DIR0,XUAUTO I "Nn"[$E(X,1) S X="" Q
13 I "Yy"'[$E(X,1) K X Q
14 S XUAUTO=($P($G(^XTV(8989.3,1,3)),U,1)="y"),XUH=""
15AC1 D CLR,AUTO:XUAUTO,AASK:'XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),AC1:'XUK D CLR,AST(XUH)
16 G OUT
17 ;
18AASK N X,XUU X ^%ZOSF("EOFF")
19AASK1 W "Enter a new ACCESS CODE <Hidden>: " D GET Q:$D(DIRUT)
20 I X="@" D DEL G:Y'=1 DIRUT S XUH="" Q
21 ;"K. Toppenberg modified 11-19-04 to relax requirements
22 I X[$C(34)!(X[";")!(X["^")!(X[":")!($L(X)>20)!($L(X)<5)!(X="MAIL-BOX") D CLR W *7,$$AVHLPTXT(1) D AHELP G AASK1
23 ;"//kt I X[$C(34)!(X[";")!(X["^")!(X[":")!(X'?.UNP)!($L(X)>20)!($L(X)<6)!(X="MAIL-BOX") D CLR W *7,$$AVHLPTXT(1) D AHELP G AASK1
24 ;"//kt I 'XUAUTO,((X?6.20A)!(X?6.20N)) D CLR W *7,"ACCESS CODE must be a mix of alpha and numerics.",! G AASK1
25 S XUU=X,X=$$EN^XUSHSH(X),XUH=X,XMB(1)=$O(^VA(200,"A",XUH,0))
26 I XMB(1),XMB(1)'=DA S XMB="XUS ACCESS CODE VIOLATION",XMB(1)=$P(^VA(200,XMB(1),0),"^"),XMDUN="Security" D ^XMB
27 I $D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)) D CLR W *7,"This has been used previously as an ACCESS CODE.",! G AASK1
28 Q
29 ;
30REASK S XUK=1 Q:XUH="" D CLR X ^%ZOSF("EOFF")
31 F XUK=3:-1:1 W "Please re-type the new code to show that I have it right: " D GET G:$D(DIRUT) DIRUT D ^XUSHSH Q:(XUH=X) D CLR W "This doesn't match. Try again!",!,*7
32 S:XUH'=X XUK=0
33 Q
34 ;
35AST(XUH) ;Change ACCESS CODE and index.
36 W "OK, Access code has been changed!"
37 ;S XUU=$P(^VA(200,DA,0),"^",3),$P(^VA(200,DA,0),"^",3)=XUH
38 ;I XUU]"" F XUI=0:0 S X=XUU S XUI=$O(^DD(200,2,1,XUI)) Q:XUI'>0 X ^(XUI,2)
39 ;I XUH]"" F XUI=0:0 S X=XUH S XUI=$O(^DD(200,2,1,XUI)) Q:XUI'>0 X ^(XUI,1)
40 N FDA,IEN,ERR
41 S IEN=DA_","
42 S FDA(200,IEN,2)=XUH D FILE^DIE("","FDA","ERR")
43 W !,"The VERIFY CODE has been deleted as a security measure.",!,"The user will have to enter a new one the next time they sign-on.",*7 D VST("",1)
44 I $D(^XMB(3.7,DA,0))[0 S Y=DA D NEW^XM ;Make sure has a Mailbox
45 Q
46 ;
47GET ;Get the user input and convert case.
48 S X=$$ACCEPT^XUS Q:X="@" G:(X["^")!('$L(X)) DIRUT
49 S X=$$UP^XLFSTR(X)
50 Q
51 ;
52DIRUT S DIRUT=1
53 Q
54 ;
55CLR I '$D(DDS) W ! Q
56 N DX,DY
57 D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X IOXY
58 Q
59 ;
60NEWCODE D REASK I XUK W !,"OK, remember this code for next time!"
61 G OUT
62 ;
63CVC ;From XUS1
64 W !,"You must change your VERIFY CODE at this time." S DA=DUZ,X="Y"
65VERED ; VERIFY CODE EDIT From DD
66 N DIR,DIR0 I "Nn"[$E(X,1) S X="" Q
67 I "Yy"'[$E(X,1) K X Q
68 S XUH=""
69VC1 D CLR,VASK G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),VC1:'XUK D CLR,VST(XUH,1)
70 D CALL^XUSERP(DA,2)
71 G OUT
72 ;
73VASK N X,XUU X ^%ZOSF("EOFF") G:'$$CHKCUR() DIRUT D CLR
74VASK1 W "Enter a new VERIFY CODE: " D GET Q:$D(DIRUT)
75 I '$D(XUNC),(X="@") D DEL G:Y'=1 DIRUT S XUH="" Q
76 D CLR S XUU=X,X=$$EN^XUSHSH(X),XUH=X,Y=$$VCHK(XUU,XUH) I +Y W *7,$P(Y,U,2,9),! D:+Y=1 VHELP G VASK1
77 Q
78 ;
79VCHK(S,EC) ;Call with String and Encripted versions
80 ;Updated per VHA directive 6210 Strong Passwords
81 ;"Kevin Toppenberg modified this 11-19-04 to relax password ("verify code") requirements.
82 ;" .. now it must just be length 8-20
83 N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/"
84 S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA)
85 I ($L(S)<5)!($L(S)>20)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT
86 ;"//I ($L(S)<8)!($L(S)>20)!(S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT
87 ;"//kt I (S?8.20A)!(S?8.20N)!(S?8.20P)!(S?8.20AN)!(S?8.20AP)!(S?8.20NP) Q "2^VERIFY CODE must be a mix of alpha and numerics and punctuation."
88 ;"//kt I $D(^VA(200,DA,.1)),EC=$P(^(.1),U,2) Q "3^This code is the same as the current one."
89 ;"//kt I $D(^VA(200,DA,"VOLD",EC)) Q "4^This has been used previously as the VERIFY CODE."
90 ;"//kt I EC=$P(^VA(200,DA,0),U,3) Q "5^VERIFY CODE must be different than the ACCESS CODE."
91 ;"//kt I S[$P(NA,"^")!(S[$P(NA,"^",2)) Q "6^Name cannot be part of code."
92 Q 0
93 ;
94VST(XUH,%) W:$L(XUH)&% !,"OK, Verify code has been changed!"
95 ;S XUU=$P($G(^VA(200,DA,.1)),U,2) S $P(^VA(200,DA,.1),"^",1,2)=$H_"^"_XUH
96 ;I XUU]"" F XUI=0:0 S X=XUU S XUI=$O(^DD(200,11,1,XUI)) Q:XUI'>0 X ^(XUI,2)
97 ;I XUH]"" F XUI=0:0 S X=XUH S XUI=$O(^DD(200,11,1,XUI)) Q:XUI'>0 X ^(XUI,1)
98 N FDA,IEN,ERR S IEN=DA_","
99 S:XUH="" XUH="@" ;11.2 get triggerd
100 S FDA(200,IEN,11)=XUH D FILE^DIE("","FDA","ERR")
101 I $D(ERR) D ^%ZTER
102 S:DA=DUZ DUZ("NEWCODE")=XUH Q
103 ;
104DEL ;
105 X ^%ZOSF("EON") W "@",*7 S DIR(0)="Y",DIR("A")="Sure you want to delete" D ^DIR I Y'=1 W:$X>55 !?9 W *7," <Nothing Deleted>"
106 Q
107 ;
108AUTO ;
109 X ^%ZOSF("EON") F XUK=1:1:3 D GEN Q:(Y=1)!($D(DIRUT))
110 K DIR
111 Q
112 ;
113GEN ;Generate a ACCESS code
114 S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G GEN
115 D CLR W "The new ACCESS CODE is: ",XUU," This is ",XUK," of 3 tries."
116YN S Y=1 Q:XUK=3 S DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!"
117 D ^DIR Q:(Y=1)!$D(DIRUT) D CLR W:XUK=2 "O.K. You'll have to keep the next one!",!
118 Q
119 ;
120AHELP S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AHELP
121 W !,"Here is an example of an acceptable Access Code: ",XUU,!
122 Q
123 ;
124VHELP S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VHELP
125 W !,"Here is an example of an acceptable Verify Code: ",XUU,!
126 Q
127 ;
128OUT ;
129 K DUOUT S:$D(DIRUT) DUOUT=1
130 X ^%ZOSF("EON") W !
131 K DIR,DIRUT,XUKO,XUAUTO,XUU,XUH,XUK,XUI S X=""
132 Q
133 ;
134CHKCUR() ;Check user knows current code, Return 1 if OK to continue
135 Q:DA'=DUZ 1 ;Only ask user
136 Q:$P($G(^VA(200,DA,.1)),U,2)="" 1 ;Must have an old one
137 S XUK=0 D CLR
138CHK1 W "Please enter your CURRENT verify code: " D GET Q:$D(DIRUT) 0
139 I $P(^VA(200,DA,.1),U,2)=$$EN^XUSHSH(X) Q 1
140 D CLR W "Sorry that is not correct!",!
141 S XUK=XUK+1 G:XUK<3 CHK1
142 Q 0
143 ;
144BRCVC(XV1,XV2) ;Broker change VC, return 0 if good, '1^msg' if bad.
145 N XUU,XUH
146 Q:$G(DUZ)'>0 "1^Bad DUZ" S DA=DUZ,XUH=$$EN^XUSHSH(XV2)
147 I $P($G(^VA(200,DUZ,.1)),"^",2)'=$$EN^XUSHSH(XV1) Q "1^Sorry that isn't the correct current code"
148 S Y=$$VCHK(XV2,XUH) Q:Y Y
149 D VST(XUH,0),CALL^XUSERP(DA,2)
150 Q 0
151 ;
152AVHLPTXT(%) ;
153 Q "Enter "_$S($G(%):"6-20",1:"8-20")_" characters mixed alphanumeric and punctuation (except '^', ';', ':')."
154 ;
Note: See TracBrowser for help on using the repository browser.