- RMPRSEC ;PHX/JLT-PROSTHETICS SECURITY CHECK ;10/01/1994
- ;;3.0;PROSTHETICS;;Feb 09, 1996
- RO ;REQUESTING OFFICAL SIGNATURE
- S X1="" K DIR S DIR(0)="F^1:30",DIR("A")="Electronic Signature Code of Requesting Official" G SIG
- AP ;APPROVING OFFICIAL SIGNATURE
- ;VARIABLE REQUIRED - DUZ
- S X1="" K DIR S DIR(0)="FO^1:30",DIR("A")="Electronic Signature Code of Approving Official" D SIG Q ;K ^RMPR(664,"AP",RMPR("SITE"),
- IP ;INSPECTING OFFICIAL SIGNATURE
- S X1="" K DIR S DIR(0)="F^1:30",DIR("A")="Electronic Signature Code of Inspecting Official" G SIG
- EX ;COLLECT SIGNATURE OF EXAMINER
- ;CALLED BY RMPREYC
- ;VARIABLE REQUIRED - DUZ
- S X1="" K DIR S DIR(0)="F^1:30",DIR("A")="Electronic Signature Code of Examiner"
- SIG S RMPRC=0
- CHK S X1=$S($D(^VA(200,+$G(DUZ),20))[0:"",1:$P(^(20),"^",4),1:"") I X1="" W !!,$C(7),?5,"YOU DO NOT HAVE AN ELECTRONIC SIGNATURE CODE.",!,?5,"USE THE TBOX OPTION TO ENTER OR CHANGE YOUR SIGNATURE CODE" Q
- X ^%ZOSF("EOFF") D WRT D ^DIR X ^%ZOSF("EON")
- S RMPRX=X W:RMPRX="^"!(X["?") RMPRX
- Q:RMPRX="^"
- W:$D(DIRUT) !!,?5,$C(7),"This document must be signed for Authentication Purposes!!" K X1 Q:$D(DIRUT)
- I RMPRC>2 W !!,$C(7),?5,"Use the TBOX option to change your Electronic Signature code." Q
- D HASH^XUSHSHP I $P(^VA(200,DUZ,20),U,4)'=X W !!,$C(7),?5,"**That is not your Electronic Signature Code. Try again**",!! S RMPRC=RMPRC+1 G CHK
- S RMPRSBP=$P(^VA(200,DUZ,20),U,2),RMPRSBT=$P(^(20),U,3),X1=X W !!,?5,$C(7),"Signature Code verified!" Q
- ENCODE(X,X1,X2) ;ENCRYPT ELECTRONIC SIGNATURE
- D EN^XUSHSHP Q X
- DECODE(X,X1,X2) ;DECRYPT ELECTRONIC SIGNATURE
- D DE^XUSHSHP Q X
- SUM(X) ;CREATE CHECKSUM VALUE FOR STRING
- N I,Y
- S Y=0 F I=1:1:$L(X) S Y=$A(X,I)*I+Y
- Q Y
- WRT ;WRITE HELP SCREENS FOR ELECTRONIC SIGNATURE PROMPTS
- S DIR("?")="YOU MUST ENTER YOUR CORRECT ELECTRONIC SIGNATURE CODE TO ACCOMPLISH THE ACTION"
- S DIR("??")="RMPR-ELECTRONIC SIGNATURE" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSEC 1912 printed Mar 13, 2025@21:42:37 Page 2
- RMPRSEC ;PHX/JLT-PROSTHETICS SECURITY CHECK ;10/01/1994
- +1 ;;3.0;PROSTHETICS;;Feb 09, 1996
- RO ;REQUESTING OFFICAL SIGNATURE
- +1 SET X1=""
- KILL DIR
- SET DIR(0)="F^1:30"
- SET DIR("A")="Electronic Signature Code of Requesting Official"
- GOTO SIG
- AP ;APPROVING OFFICIAL SIGNATURE
- +1 ;VARIABLE REQUIRED - DUZ
- +2 ;K ^RMPR(664,"AP",RMPR("SITE"),
- SET X1=""
- KILL DIR
- SET DIR(0)="FO^1:30"
- SET DIR("A")="Electronic Signature Code of Approving Official"
- DO SIG
- QUIT
- IP ;INSPECTING OFFICIAL SIGNATURE
- +1 SET X1=""
- KILL DIR
- SET DIR(0)="F^1:30"
- SET DIR("A")="Electronic Signature Code of Inspecting Official"
- GOTO SIG
- EX ;COLLECT SIGNATURE OF EXAMINER
- +1 ;CALLED BY RMPREYC
- +2 ;VARIABLE REQUIRED - DUZ
- +3 SET X1=""
- KILL DIR
- SET DIR(0)="F^1:30"
- SET DIR("A")="Electronic Signature Code of Examiner"
- SIG SET RMPRC=0
- CHK SET X1=$SELECT($DATA(^VA(200,+$GET(DUZ),20))[0:"",1:$PIECE(^(20),"^",4),1:"")
- IF X1=""
- WRITE !!,$CHAR(7),?5,"YOU DO NOT HAVE AN ELECTRONIC SIGNATURE CODE.",!,?5,"USE THE TBOX OPTION TO ENTER OR CHANGE YOUR SIGNATURE CODE"
- QUIT
- +1 XECUTE ^%ZOSF("EOFF")
- DO WRT
- DO ^DIR
- XECUTE ^%ZOSF("EON")
- +2 SET RMPRX=X
- if RMPRX="^"!(X["?")
- WRITE RMPRX
- +3 if RMPRX="^"
- QUIT
- +4 if $DATA(DIRUT)
- WRITE !!,?5,$CHAR(7),"This document must be signed for Authentication Purposes!!"
- KILL X1
- if $DATA(DIRUT)
- QUIT
- +5 IF RMPRC>2
- WRITE !!,$CHAR(7),?5,"Use the TBOX option to change your Electronic Signature code."
- QUIT
- +6 DO HASH^XUSHSHP
- IF $PIECE(^VA(200,DUZ,20),U,4)'=X
- WRITE !!,$CHAR(7),?5,"**That is not your Electronic Signature Code. Try again**",!!
- SET RMPRC=RMPRC+1
- GOTO CHK
- +7 SET RMPRSBP=$PIECE(^VA(200,DUZ,20),U,2)
- SET RMPRSBT=$PIECE(^(20),U,3)
- SET X1=X
- WRITE !!,?5,$CHAR(7),"Signature Code verified!"
- QUIT
- ENCODE(X,X1,X2) ;ENCRYPT ELECTRONIC SIGNATURE
- +1 DO EN^XUSHSHP
- QUIT X
- DECODE(X,X1,X2) ;DECRYPT ELECTRONIC SIGNATURE
- +1 DO DE^XUSHSHP
- QUIT X
- SUM(X) ;CREATE CHECKSUM VALUE FOR STRING
- +1 NEW I,Y
- +2 SET Y=0
- FOR I=1:1:$LENGTH(X)
- SET Y=$ASCII(X,I)*I+Y
- +3 QUIT Y
- WRT ;WRITE HELP SCREENS FOR ELECTRONIC SIGNATURE PROMPTS
- +1 SET DIR("?")="YOU MUST ENTER YOUR CORRECT ELECTRONIC SIGNATURE CODE TO ACCOMPLISH THE ACTION"
- +2 SET DIR("??")="RMPR-ELECTRONIC SIGNATURE"
- QUIT
