XOBWPWD ;ALB/MJK - HWSC :: Private Password APIs ; 09/13/10 4:00pm
;;1.0;HwscWebServiceClient;;September 13, 2010;Build 31
;
; -- used XOBVJC1 as seed
;
QUIT
;
EDIT ; -- edit PASSWORD from DD
NEW DIR,DIR0,XOBH,XOBMATCH
SET XOBMATCH=0
;
; -- if not 'y'es
IF "Nn"[$EXTRACT(X,1) SET X="" QUIT
IF "Yy"'[$EXTRACT(X,1) KILL X QUIT
;
; -- get good hash or until abort by user
FOR DO QUIT:XOBMATCH!($DATA(DIRUT))
. DO CLR
. SET XOBH=$$ASK()
. IF $DATA(DIRUT) QUIT
. SET XOBMATCH=$$REASK(XOBH)
;
; -- if good hash set in file
IF XOBMATCH DO
. DO CLR
. DO SET(XOBH,1)
;
; -- clean up
KILL DUOUT
IF $DATA(DIRUT) SET DUOUT=1
XECUTE ^%ZOSF("EON") WRITE !
KILL DIR,DIRUT SET X=""
QUIT
;
CLR ; -- clear to continue
IF '$DATA(DDS) WRITE ! QUIT
NEW DX,DY
DO CLRMSG^DDS SET DX=0,DY=DDSHBX+1 XECUTE IOXY
QUIT
;
SET(XOBH,XOBTALK) ; -- set password in entry
IF $LENGTH(XOBH),XOBTALK WRITE !,"Ok, password has been changed!"
NEW FDA,XOBERR
IF XOBH="" SET XOBH="@"
; -- password
SET FDA(18.12,$$IENS^DILF(.DA),300)=XOBH
DO FILE^DIE("","FDA","XOBERR")
IF $DATA(XOBERR) DO ^%ZTER
QUIT
;
DEL ; -- make sure delete is desired
XECUTE ^%ZOSF("EON")
WRITE "@",*7
SET DIR(0)="Y",DIR("A")="Sure you want to delete"
DO ^DIR
IF Y'=1 WRITE:$X>55 !?9 WRITE *7," <Nothing Deleted>"
QUIT
;
DIRUT ; -- set abort flag
SET DIRUT=1
QUIT
;
ASK() ; -- setup to ask user for password
NEW X,XOBX,XOBH
XECUTE ^%ZOSF("EOFF")
DO CLR
WRITE "Enter a new PASSWORD: "
SET XOBX=$$GET()
IF $DATA(DIRUT) QUIT ""
IF XOBX="@" DO QUIT ""
. DO DEL
. IF Y'=1 DO DIRUT
;
DO CLR
QUIT $$ENCRYP(XOBX)
;
REASK(XOBH) ; -- reask user for password
NEW XOBX,XOBDONE,XOBMATCH,XOBI
SET XOBDONE=0
SET XOBMATCH=1
;
; -- if deleting then auto-match
IF XOBH="" QUIT XOBMATCH
;
SET XOBMATCH=0
DO CLR
XECUTE ^%ZOSF("EOFF")
FOR XOBI=3:-1:1 DO QUIT:XOBDONE
. WRITE "Please re-type the new password to show that I have it right: "
. SET XOBX=$$GET()
. ; -- user is up-arrowing out
. IF $DATA(DIRUT) SET XOBDONE=1 QUIT
. ;
. IF XOBX'=$$DECRYP(XOBH) DO QUIT
. . DO CLR
. . WRITE "This doesn't match. Try again!",!,*7
. ; -- match entered
. SET XOBDONE=1
. SET XOBMATCH=1
QUIT XOBMATCH
;
GET() ; -- get user input and process for '^' and ''
SET X=$$ACCEPT(60)
IF X="@" QUIT X
IF (X["^")!('$LENGTH(X)) DO DIRUT
QUIT X
;
ACCEPT(TO) ; -- read user input character a time; force exit on '^'; echo '*' back
NEW C,A,E
KILL DUOUT
SET A="",TO=$GET(TO,60),E=0
FOR DO QUIT:E
. READ "",*C:TO SET:('$TEST) DUOUT=1 SET:('$TEST)!(C=94) A="^"
. IF (A="^")!(C=13)!($LENGTH(A)>100) SET E=1 QUIT
. IF C=127 QUIT:'$LENGTH(A) SET A=$EXTRACT(A,1,$LENGTH(A)-1) WRITE $CHAR(8,32,8) QUIT
. SET A=A_$CHAR(C) WRITE *42
. QUIT
QUIT A
;
ENCRYP(XOBX) ; -- Kernel encode
QUIT $$ENCRYP^XUSRB1(XOBX)
;
DECRYP(XOBH) ; -- Kernel decode
QUIT $$DECRYP^XUSRB1(XOBH)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBWPWD 2997 printed Apr 09, 2024@21:48:27 Page 2
XOBWPWD ;ALB/MJK - HWSC :: Private Password APIs ; 09/13/10 4:00pm
+1 ;;1.0;HwscWebServiceClient;;September 13, 2010;Build 31
+2 ;
+3 ; -- used XOBVJC1 as seed
+4 ;
+5 QUIT
+6 ;
EDIT ; -- edit PASSWORD from DD
+1 NEW DIR,DIR0,XOBH,XOBMATCH
+2 SET XOBMATCH=0
+3 ;
+4 ; -- if not 'y'es
+5 IF "Nn"[$EXTRACT(X,1)
SET X=""
QUIT
+6 IF "Yy"'[$EXTRACT(X,1)
KILL X
QUIT
+7 ;
+8 ; -- get good hash or until abort by user
+9 FOR
Begin DoDot:1
+10 DO CLR
+11 SET XOBH=$$ASK()
+12 IF $DATA(DIRUT)
QUIT
+13 SET XOBMATCH=$$REASK(XOBH)
End DoDot:1
if XOBMATCH!($DATA(DIRUT))
QUIT
+14 ;
+15 ; -- if good hash set in file
+16 IF XOBMATCH
Begin DoDot:1
+17 DO CLR
+18 DO SET(XOBH,1)
End DoDot:1
+19 ;
+20 ; -- clean up
+21 KILL DUOUT
+22 IF $DATA(DIRUT)
SET DUOUT=1
+23 XECUTE ^%ZOSF("EON")
WRITE !
+24 KILL DIR,DIRUT
SET X=""
+25 QUIT
+26 ;
CLR ; -- clear to continue
+1 IF '$DATA(DDS)
WRITE !
QUIT
+2 NEW DX,DY
+3 DO CLRMSG^DDS
SET DX=0
SET DY=DDSHBX+1
XECUTE IOXY
+4 QUIT
+5 ;
SET(XOBH,XOBTALK) ; -- set password in entry
+1 IF $LENGTH(XOBH)
IF XOBTALK
WRITE !,"Ok, password has been changed!"
+2 NEW FDA,XOBERR
+3 IF XOBH=""
SET XOBH="@"
+4 ; -- password
+5 SET FDA(18.12,$$IENS^DILF(.DA),300)=XOBH
+6 DO FILE^DIE("","FDA","XOBERR")
+7 IF $DATA(XOBERR)
DO ^%ZTER
+8 QUIT
+9 ;
DEL ; -- make sure delete is desired
+1 XECUTE ^%ZOSF("EON")
+2 WRITE "@",*7
+3 SET DIR(0)="Y"
SET DIR("A")="Sure you want to delete"
+4 DO ^DIR
+5 IF Y'=1
if $X>55
WRITE !?9
WRITE *7," <Nothing Deleted>"
+6 QUIT
+7 ;
DIRUT ; -- set abort flag
+1 SET DIRUT=1
+2 QUIT
+3 ;
ASK() ; -- setup to ask user for password
+1 NEW X,XOBX,XOBH
+2 XECUTE ^%ZOSF("EOFF")
+3 DO CLR
+4 WRITE "Enter a new PASSWORD: "
+5 SET XOBX=$$GET()
+6 IF $DATA(DIRUT)
QUIT ""
+7 IF XOBX="@"
Begin DoDot:1
+8 DO DEL
+9 IF Y'=1
DO DIRUT
End DoDot:1
QUIT ""
+10 ;
+11 DO CLR
+12 QUIT $$ENCRYP(XOBX)
+13 ;
REASK(XOBH) ; -- reask user for password
+1 NEW XOBX,XOBDONE,XOBMATCH,XOBI
+2 SET XOBDONE=0
+3 SET XOBMATCH=1
+4 ;
+5 ; -- if deleting then auto-match
+6 IF XOBH=""
QUIT XOBMATCH
+7 ;
+8 SET XOBMATCH=0
+9 DO CLR
+10 XECUTE ^%ZOSF("EOFF")
+11 FOR XOBI=3:-1:1
Begin DoDot:1
+12 WRITE "Please re-type the new password to show that I have it right: "
+13 SET XOBX=$$GET()
+14 ; -- user is up-arrowing out
+15 IF $DATA(DIRUT)
SET XOBDONE=1
QUIT
+16 ;
+17 IF XOBX'=$$DECRYP(XOBH)
Begin DoDot:2
+18 DO CLR
+19 WRITE "This doesn't match. Try again!",!,*7
End DoDot:2
QUIT
+20 ; -- match entered
+21 SET XOBDONE=1
+22 SET XOBMATCH=1
End DoDot:1
if XOBDONE
QUIT
+23 QUIT XOBMATCH
+24 ;
GET() ; -- get user input and process for '^' and ''
+1 SET X=$$ACCEPT(60)
+2 IF X="@"
QUIT X
+3 IF (X["^")!('$LENGTH(X))
DO DIRUT
+4 QUIT X
+5 ;
ACCEPT(TO) ; -- read user input character a time; force exit on '^'; echo '*' back
+1 NEW C,A,E
+2 KILL DUOUT
+3 SET A=""
SET TO=$GET(TO,60)
SET E=0
+4 FOR
Begin DoDot:1
+5 READ "",*C:TO
if ('$TEST)
SET DUOUT=1
if ('$TEST)!(C=94)
SET A="^"
+6 IF (A="^")!(C=13)!($LENGTH(A)>100)
SET E=1
QUIT
+7 IF C=127
if '$LENGTH(A)
QUIT
SET A=$EXTRACT(A,1,$LENGTH(A)-1)
WRITE $CHAR(8,32,8)
QUIT
+8 SET A=A_$CHAR(C)
WRITE *42
+9 QUIT
End DoDot:1
if E
QUIT
+10 QUIT A
+11 ;
ENCRYP(XOBX) ; -- Kernel encode
+1 QUIT $$ENCRYP^XUSRB1(XOBX)
+2 ;
DECRYP(XOBH) ; -- Kernel decode
+1 QUIT $$DECRYP^XUSRB1(XOBH)
+2 ;
