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

XUSESIG.m

Go to the documentation of this file.
  1. XUSESIG ;SF/RWF - ROUTINE TO ENTER OR CHANGE ELECTRONIC SIGNATURE CODE ; 09 Mar 2017 10:17 AM
  1. ;;8.0;KERNEL;**14,55,437,679**;Jul 10, 1995;Build 27
  1. ;
  1. ; ^XUSEC read supported by ICR #10076.
  1. ;
  1. A ;Called by others from the top. See DBIC #936
  1. I $D(DUZ)[0 W "NO ACTION CAN BE TAKEN ON YOUR REQUEST " Q
  1. S DA=DUZ
  1. A2 N DIE,DR,X1,K
  1. S:$D(^VA(200,DA,0))[0 DA=0
  1. I DA'>0 W !,"You don't have an entry in the NEW PERSON file, See your site manager" G OUT
  1. W !,"This option is designed to permit you to enter or change your Initials,",!
  1. N XUSGBLK S XUSGBLK=0
  1. I $$GET^XPAR("ALL","XU SIG BLOCK DISABLE") S XUSGBLK=1
  1. I 'XUSGBLK W "Signature Block Information, "
  1. W "Office Phone number, and Voice and Digital Pagers "
  1. I 'XUSGBLK W !
  1. W "numbers."
  1. W !,"In addition, you are permitted to enter a new Electronic Signature Code"
  1. W !,"or to change an existing code.",!!
  1. S DIE="^VA(200,",DR="1;.132;.137;.138"
  1. I 'XUSGBLK S DR="1;20.2;20.3;.132;.137;.138"
  1. D ^DIE
  1. I $P($G(^VA(200,DA,20)),U,2)="" W !,"You must have a SIGNATURE BLOCK PRINTED NAME before you can have",!,"an ELECTRONIC SIGNATURE CODE." G OUT1
  1. S X1=$P($G(^VA(200,DA,20)),"^",4) I X1]"" S K=0 D S2 G:X1="" OUT1
  1. S X1=$$NEW() W !,$S(X1:"DONE",1:" OPTION ABORTED."_$C(7))
  1. G OUT1
  1. ;
  1. NEW() ;Enter a NEW E-Sig code, return 0 for fail, 1 if done, 2 skip.
  1. N K,X,X1 S K=0
  1. W !!,"Your typing will not show."
  1. N2 W !,"ENTER NEW SIGNATURE CODE: " D R Q:X=""!(X="^") 2
  1. I X'?.UNP!($L(X)>20)!($L(X)<6) W *7,!,"Signature code must be 6 to 20 characters in length",!," With no control or lowercase characters.",! G N2
  1. S X1=X W !,"RE-ENTER SIGNATURE CODE FOR VERIFICATION: " D R G:X=""!(X="^") N5
  1. I X'=X1 W " CODE NOT VERIFIED, TRY AGAIN.",*7,! S K=K+1 G N5:K>3 G N2
  1. D HASH^XUSHSHP
  1. I X=$P(^VA(200,DA,20),U,4) W *7,!,"You can't use the same one.",! G N2
  1. S $P(^VA(200,DA,20),"^",4)=X
  1. F XUS=0:0 S XUS=$O(^DD(200,20.4,1,XUS)) Q:XUS'>0 X ^(XUS,1)
  1. N4 Q 1 ;OK
  1. N5 Q 0 ;FAIL
  1. ;
  1. R X ^%ZOSF("EOFF") R X:60 X ^%ZOSF("EON") S:'$T X="^" Q
  1. ;
  1. OUT W !," OPTION ABORTED.",*7
  1. OUT1 K %,D,D0,DA,DIC,DIE,DQ,DR,X,X1,A,K,I,Z,XUSGBLK Q
  1. ;
  1. SIG ;Call with DUZ; Return X1="" if fail else hashed ESC.
  1. N X2,K
  1. S X2=$G(^VA(200,+$G(DUZ),20)),X1=$P(X2,U,4) I X1="" W !,"No Electronic Signature code to check." Q
  1. S K=0 D S2 Q:X1=""
  1. Q ;Following code was to force code change
  1. N LIFE S LIFE=$$KSP^XUPARAM("LIFETIME")
  1. S X2=+X2 I X2>0,(X2+LIFE)'>(+$H) D I X1="" W !,*7,"Verification with held until new code entered.",!
  1. . W !!,"Your Electronic Signature Code has expired, you need to create a new one."
  1. . N DA S DA=DUZ S:$$NEW()'=1 X1=""
  1. . Q
  1. Q
  1. ;
  1. S2 W !!,"Enter your Current Signature Code: " D R G:X=""!(X="^") S9
  1. I X?1.2"?" W !,"Enter your current Electronic Signature Code so it can be verified.",! G S2
  1. S K=K+1 D HASH^XUSHSHP I X1'=X W " ??",*7 S X="" G S2:K<3,S9
  1. W " SIGNATURE VERIFIED"
  1. S9 S:X=""!(X="^") X1=""
  1. Q
  1. TEXT ;;
  1. CLEAR ;Clear (delete) a users ESC to allow entering a new one.
  1. S DIC=200,DIC(0)="AEMQ" D ^DIC G OUT:Y'>0 S DA=+Y,DIR(0)="Y"
  1. W !,"Clear SIGNATURE CODE from user ",$P(Y,U,2) D ^DIR G OUT1:Y'=1
  1. S DIE=DIC,DR="20.4///@" D ^DIE G OUT1
  1. Q
  1. ;;