Changeset 623 for 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/XUS2.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
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/XUS2.m
r613 r623 1 XUS2 2 ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 23 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 ACCED 22 23 24 25 26 AC1 27 28 29 AASK 30 31 32 33 34 35 AASK1 36 37 38 39 40 41 42 43 44 45 REASK 46 47 48 49 50 AST(XUH) 51 52 53 54 55 56 57 58 59 60 GET 61 62 63 64 65 DIRUT 66 67 68 CLR 69 70 71 72 73 74 NEWCODE 75 76 77 CVC 78 79 80 81 82 VERED 83 84 85 86 87 VC1 88 89 90 91 VASK 92 93 VASK1 94 95 96 97 98 VCHK(S,EC) 99 100 101 102 103 104 105 106 107 108 109 110 111 VST(XUH,%) 112 113 114 115 116 117 118 119 DEL 120 121 122 123 AAUTO 124 125 126 127 128 AGEN 129 130 131 132 133 134 AHELP 135 136 137 138 VHELP 139 140 141 142 VAUTO 143 144 145 146 147 VGEN 148 149 150 151 152 YN 153 154 155 156 157 158 OUT 159 160 161 162 163 164 CHKCUR() 165 166 167 168 CHK1 169 170 171 172 173 174 BRCVC(XV1,XV2) 175 176 177 178 179 180 181 182 AVHLPTXT(%) 183 184 185 186 187 USER 188 EDIT 1 XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;2/3/07 19:18 2 ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 22 3 Q 4 ; Modified from FOIA VISTA, 5 ; Copyright (C) 2007 WorldVistA 6 ; 7 ; This program is free software; you can redistribute it and/or modify 8 ; it under the terms of the GNU General Public License as published by 9 ; the Free Software Foundation; either version 2 of the License, or 10 ; (at your option) any later version. 11 ; 12 ; This program is distributed in the hope that it will be useful, 13 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ; GNU General Public License for more details. 16 ; 17 ; You should have received a copy of the GNU General Public License 18 ; along with this program; if not, write to the Free Software 19 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 20 ; 21 ACCED ; ACCESS CODE EDIT from DD 22 I "Nn"[$E(X,1) S X="" Q 23 I "Yy"'[$E(X,1) K X Q 24 N DIR,DIR0,XUAUTO,XUK 25 S XUAUTO=($P($G(^XTV(8989.3,1,3)),U,1)="y"),XUH="" 26 AC1 D CLR,AAUTO:XUAUTO,AASK:'XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),AC1:'XUK D CLR,AST(XUH) 27 G OUT 28 ; 29 AASK ;Ask for Access code 30 N X,XUU,XUEX X ^%ZOSF("EOFF") 31 S XUEX=0 32 F D AASK1 Q:XUEX!($D(DIRUT)) 33 Q 34 ; 35 AASK1 ; 36 W "Enter a new ACCESS CODE <Hidden>: " D GET Q:$D(DIRUT) 37 I X="@" D DEL D:Y'=1 DIRUT S XUH="",XUEX=1 Q 38 I X[$C(34)!(X[";")!(X["^")!(X[":")!(X'?.UNP)!($L(X)>20)!($L(X)<6)!(X="MAIL-BOX") D CLR W $C(7),$$AVHLPTXT(1) D AHELP Q 39 I 'XUAUTO,((X?6.20A)!(X?6.20N)) D CLR W $C(7),$$AVHLPTXT(1),! Q 40 S XUU=X,X=$$EN^XUSHSH(X),XUH=X,XMB(1)=$O(^VA(200,"A",XUH,0)) I XMB(1),XMB(1)'=DA S XMB="XUS ACCESS CODE VIOLATION",XMB(1)=$P(^VA(200,XMB(1),0),"^"),XMDUN="Security" D ^XMB 41 I $D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)) D CLR W $C(7),"This has been used previously as an ACCESS CODE.",! Q 42 S XUEX=1 ;Now we can quit 43 Q 44 ; 45 REASK S XUK=1 Q:XUH="" D CLR X ^%ZOSF("EOFF") 46 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!",!,$C(7) 47 S:XUH'=X XUK=0 48 Q 49 ; 50 AST(XUH) ;Change ACCESS CODE and index. 51 W "OK, Access code has been changed!" 52 N FDA,IEN,ERR 53 S IEN=DA_"," 54 S FDA(200,IEN,2)=XUH D FILE^DIE("","FDA","ERR") 55 W !,"The VERIFY CODE has been deleted as a security measure.",!,"You will need to enter a new VERIFY code so the user can sign-on.",$C(7) 56 D VST("",1) 57 I $D(^XMB(3.7,DA,0))[0 S Y=DA D NEW^XM ;Make sure has a Mailbox 58 Q 59 ; 60 GET ;Get the user input and convert case. 61 S X=$$ACCEPT^XUS I (X["^")!('$L(X)) D DIRUT 62 I '$D(ASKINGVC)!'$$GET^XPAR("SYS","XU VC CASE SENSITIVE") S X=$$UP^XLFSTR(X) ;for VOE allow case sensitive Verify Code 63 Q 64 ; 65 DIRUT S DIRUT=1 66 Q 67 ; 68 CLR ;New line or Clear screenman area 69 I '$D(DDS) W ! Q 70 N DX,DY 71 D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X IOXY 72 Q 73 ; 74 NEWCODE D REASK I XUK W !,"OK, remember this code for next time!" 75 G OUT 76 ; 77 CVC ;From XUS1 78 N DA,X 79 S DA=DUZ,X="Y" 80 W !,"You must change your VERIFY CODE at this time." 81 ;Fall into next code 82 VERED ; VERIFY CODE EDIT From DD 83 N DIR,DIR0,XUAUTO,ASKINGVC 84 I "Nn"[$E(X,1) S X="" Q 85 I "Yy"'[$E(X,1) K X Q 86 S ASKINGVC=1,XUH="",XUAUTO=($P($G(^XTV(8989.3,1,3)),U,3)="y") S:DUZ=DA XUAUTO="n" ;Auto only for admin 87 VC1 D CLR,VASK:'XUAUTO,VAUTO:XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),VC1:'XUK D CLR,VST(XUH,1) 88 D CALL^XUSERP(DA,2) 89 G OUT 90 ; 91 VASK ;Ask for Verify Code 92 N X,XUU X ^%ZOSF("EOFF") G:'$$CHKCUR() DIRUT D CLR 93 VASK1 W "Enter a new VERIFY CODE: " D GET Q:$D(DIRUT) 94 I '$D(XUNC),(X="@") D DEL G:Y'=1 DIRUT S XUH="" Q 95 D CLR S XUU=X,X=$$EN^XUSHSH(X),XUH=X,Y=$$VCHK(XUU,XUH) I +Y W $C(7),$P(Y,U,2,9),! D:+Y=1 VHELP G VASK1 96 Q 97 ; 98 VCHK(S,EC) ;Call with String and Encripted versions 99 ;Updated per VHA directive 6210 Strong Passwords 100 N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/" 101 S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA) 102 ; for VOE allow case sensitive Verify Code with S'?.ANP 103 I ($L(S)<8)!($L(S)>20)!$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):S'?.ANP,1:S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT 104 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." 105 I $D(^VA(200,DA,.1)),EC=$P(^(.1),U,2) Q "3^This code is the same as the current one." 106 I $D(^VA(200,DA,"VOLD",EC)) Q "4^This has been used previously as the VERIFY CODE." 107 I EC=$P(^VA(200,DA,0),U,3) Q "5^VERIFY CODE must be different than the ACCESS CODE." 108 I S[$P(NA,"^")!(S[$P(NA,"^",2)) Q "6^Name cannot be part of code." 109 Q 0 110 ; 111 VST(XUH,%) ; 112 W:$L(XUH)&% !,"OK, Verify code has been changed!" 113 N FDA,IEN,ERR S IEN=DA_"," 114 S:XUH="" XUH="@" ;11.2 get triggerd 115 S FDA(200,IEN,11)=XUH D FILE^DIE("","FDA","ERR") 116 I $D(ERR) D ^%ZTER 117 S:DA=DUZ DUZ("NEWCODE")=XUH Q 118 ; 119 DEL ; 120 X ^%ZOSF("EON") W $C(7) S DIR(0)="Y",DIR("A")="Sure you want to delete" D ^DIR I Y'=1 W:$X>55 !?9 W $C(7)," <Nothing Deleted>" 121 Q 122 ; 123 AAUTO ;Auto-get Access codes 124 N XUK,Y 125 X ^%ZOSF("EON") F XUK=1:1:3 D AGEN Q:(Y=1)!($D(DIRUT)) 126 Q 127 ; 128 AGEN ;Generate a ACCESS code 129 S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AGEN 130 D CLR W "The new ACCESS CODE is: ",XUU," This is ",XUK," of 3 tries." 131 D YN 132 Q 133 ; 134 AHELP S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AHELP 135 W !,"Here is an example of an acceptable Access Code: ",XUU,! 136 Q 137 ; 138 VHELP 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 139 W !,"Here is an example of an acceptable Verify Code: ",XUU,! 140 Q 141 ; 142 VAUTO ;Auto-get Access codes 143 N XUK 144 X ^%ZOSF("EON") F XUK=1:1:3 D VGEN Q:(Y=1)!($D(DIRUT)) 145 Q 146 ; 147 VGEN ;Generate a VERIFY code 148 S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VGEN 149 D CLR W "The new VERIFY CODE is: ",XUU," This is ",XUK," of 3 tries." 150 D YN 151 Q 152 YN ;Ask if want to keep 153 N DIR 154 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!" 155 D ^DIR Q:(Y=1)!$D(DIRUT) D CLR W:XUK=2 "O.K. You'll have to keep the next one!",! 156 Q 157 ; 158 OUT ; 159 K DUOUT S:$D(DIRUT) DUOUT=1 160 X ^%ZOSF("EON") W ! 161 K DIR,DIRUT,XUKO,XUAUTO,XUU,XUH,XUK,XUI S X="" 162 Q 163 ; 164 CHKCUR() ;Check user knows current code, Return 1 if OK to continue 165 Q:DA'=DUZ 1 ;Only ask user 166 Q:$P($G(^VA(200,DA,.1)),U,2)="" 1 ;Must have an old one 167 S XUK=0 D CLR 168 CHK1 W "Please enter your CURRENT verify code: " D GET Q:$D(DIRUT) 0 169 I $P(^VA(200,DA,.1),U,2)=$$EN^XUSHSH(X) Q 1 170 D CLR W "Sorry that is not correct!",! 171 S XUK=XUK+1 G:XUK<3 CHK1 172 Q 0 173 ; 174 BRCVC(XV1,XV2) ;Broker change VC, return 0 if good, '1^msg' if bad. 175 N XUU,XUH 176 Q:$G(DUZ)'>0 "1^Bad DUZ" S DA=DUZ,XUH=$$EN^XUSHSH(XV2) 177 I $P($G(^VA(200,DUZ,.1)),"^",2)'=$$EN^XUSHSH(XV1) Q "1^Sorry that isn't the correct current code" 178 S Y=$$VCHK(XV2,XUH) Q:Y Y 179 D VST(XUH,0),CALL^XUSERP(DA,2) 180 Q 0 181 ; 182 AVHLPTXT(%) ; 183 Q "Enter "_$S($G(%):"6-20",1:"8-20")_" characters mixed alphanumeric and punctuation (except '^', ';', ':')." 184 ; 185 ;Left over code, Don't think it is called anymore. 186 G XUS2^XUVERIFY ;All check or return user attributes moved to XUVERIFY 187 USER G USER^XUVERIFY 188 EDIT G EDIT^XUVERIFY
Note:
See TracChangeset
for help on using the changeset viewer.
