| 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
|
|---|
