Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XOBWPWD

XOBWPWD.m

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