SDECPAT4 ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
;
Q
;
; This routine is passed a patient ien and returns an encrypted patient
; identifier 12 bytes long. The entry point DEC reverses the process
; and returns the decoded output in a 27 byte long string.
;
ENC(DFN) ;EP - RETURN ENCRYPTED PATIENT IDENTIFIER
NEW AUPNV,AUPNX,AUPNY,I,X,X1,Y
S AUPNV=""
G:'$G(DFN) ENCX ; exit if no patient ien passed
G:'$D(^DPT(DFN,0)) ENCX ; exit if patient doesn't exist
;----------
; take 1st 3 chars of name, replace punctuation with numbers, pad out
; to 3 chars
S AUPNX=$E($P($P(^DPT(DFN,0),U),","),1,3)
S AUPNX=$TR(AUPNX," '-.,","01234")
F I=1:1:(3-$L(AUPNX)) S AUPNX=AUPNX_"5"
S AUPNV=AUPNX
;----------
; take 1st initial, 0 if null
S AUPNX=$E($P($P(^DPT(DFN,0),U),",",2)) S:AUPNX="" AUPNX=0
;----------
; concatenate in reverse order
S AUPNV=$E(AUPNV,3)_$E(AUPNV,2)_$E(AUPNV)_AUPNX
;----------
; concatenate fileman date of birth (converted to $H/hex format)
S AUPNX=$$DOB^SDECPAT(DFN) S:$L(AUPNX)'=7 AUPNX=3991231
S AUPNX=$$FMTH^XLFDT(AUPNX,1)
S X=AUPNX,X1=16 D CNV^XTBASE S Y=$E(Y,1,4)
F I=1:1:(4-$L(Y)) S Y=Y_"-"
S AUPNV=AUPNV_Y
;----------
; concatenate last 4 digits of SSN
S AUPNX=$E($$SSN^SDECPAT(DFN),6,9) S:$L(AUPNX)'=4 AUPNX="9999"
F I=1:1:4 D
. S X=$E(AUPNX,I)
. I X<5 S X=X+5,$E(AUPNX,I)=X I 1
. E S X=X-5,$E(AUPNX,I)=X
. Q
S AUPNV=AUPNV_AUPNX
;----------
; shuffle
S AUPNV=$E(AUPNV,4,6)_$E(AUPNV,10,12)_$E(AUPNV,1,3)_$E(AUPNV,7,9)
;----------
; encrypt
D ENCRYPT
;----------
ENCX ;
Q AUPNV
;
;
ENCRYPT ;
S AUPNV=$TR(AUPNV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
S AUPNV=$TR(AUPNV,"1234567890","8967320415")
Q
;
;
;
DEC(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
NEW AUPNV,AUPNX,AUPNY,I,X,X1,Y
S AUPNV=""
G:$G(PID)="" DECX ; exit if no string
G:$L(PID)'=12 DECX ; exit if string not 12 chars
S AUPNV="["
;----------
; decrypt
D DECRYPT
;----------
; unshuffle
S PID=$E(PID,7,9)_$E(PID,1,3)_$E(PID,10,12)_$E(PID,4,6)
;----------
; take 1st 3 chars of name, replace numbers with punctuation
S AUPNX=""
F I=3,2,1 S AUPNX=AUPNX_$E(PID,I)
S AUPNX=$TR(AUPNX,"01234"," '-.,")
S AUPNY=""
F I=1:1:3 S:$E(AUPNX,I)'="5" AUPNY=AUPNY_$E(AUPNX,I)
S AUPNX=AUPNY_","_$S($E(PID,4)'="0":$E(PID,4),1:"")
S AUPNV=AUPNV_AUPNX
;----------
; fileman date of birth (converted to external format)
S AUPNX=""
S X=$E(PID,5,8)
F I=1:1:4 S:$E(X,I)'="-" AUPNX=AUPNX_$E(X,I)
S X=AUPNX,X1=16 D DEC^XTBASE S AUPNX=Y
S AUPNX=$$HTE^XLFDT(AUPNX,1)
S AUPNV=AUPNV_"__"_AUPNX
;----------
; last 4 digits of SSN
S AUPNX=$E(PID,9,12)
F I=1:1:4 D
. S X=$E(AUPNX,I)
. I X<5 S X=X+5,$E(AUPNX,I)=X I 1
. E S X=X-5,$E(AUPNX,I)=X
. Q
S:AUPNX="9999" AUPNX=" "
S AUPNV=AUPNV_"__"_AUPNX
;----------
S AUPNV=AUPNV_"]"
DECX ;
Q AUPNV
;
DECRYPT ;
S PID=$TR(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S PID=$TR(PID,"8967320415","1234567890")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECPAT4 3184 printed Sep 23, 2025@20:28:48 Page 2
SDECPAT4 ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
+1 ;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
+2 ;
+3 QUIT
+4 ;
+5 ; This routine is passed a patient ien and returns an encrypted patient
+6 ; identifier 12 bytes long. The entry point DEC reverses the process
+7 ; and returns the decoded output in a 27 byte long string.
+8 ;
ENC(DFN) ;EP - RETURN ENCRYPTED PATIENT IDENTIFIER
+1 NEW AUPNV,AUPNX,AUPNY,I,X,X1,Y
+2 SET AUPNV=""
+3 ; exit if no patient ien passed
if '$GET(DFN)
GOTO ENCX
+4 ; exit if patient doesn't exist
if '$DATA(^DPT(DFN,0))
GOTO ENCX
+5 ;----------
+6 ; take 1st 3 chars of name, replace punctuation with numbers, pad out
+7 ; to 3 chars
+8 SET AUPNX=$EXTRACT($PIECE($PIECE(^DPT(DFN,0),U),","),1,3)
+9 SET AUPNX=$TRANSLATE(AUPNX," '-.,","01234")
+10 FOR I=1:1:(3-$LENGTH(AUPNX))
SET AUPNX=AUPNX_"5"
+11 SET AUPNV=AUPNX
+12 ;----------
+13 ; take 1st initial, 0 if null
+14 SET AUPNX=$EXTRACT($PIECE($PIECE(^DPT(DFN,0),U),",",2))
if AUPNX=""
SET AUPNX=0
+15 ;----------
+16 ; concatenate in reverse order
+17 SET AUPNV=$EXTRACT(AUPNV,3)_$EXTRACT(AUPNV,2)_$EXTRACT(AUPNV)_AUPNX
+18 ;----------
+19 ; concatenate fileman date of birth (converted to $H/hex format)
+20 SET AUPNX=$$DOB^SDECPAT(DFN)
if $LENGTH(AUPNX)'=7
SET AUPNX=3991231
+21 SET AUPNX=$$FMTH^XLFDT(AUPNX,1)
+22 SET X=AUPNX
SET X1=16
DO CNV^XTBASE
SET Y=$EXTRACT(Y,1,4)
+23 FOR I=1:1:(4-$LENGTH(Y))
SET Y=Y_"-"
+24 SET AUPNV=AUPNV_Y
+25 ;----------
+26 ; concatenate last 4 digits of SSN
+27 SET AUPNX=$EXTRACT($$SSN^SDECPAT(DFN),6,9)
if $LENGTH(AUPNX)'=4
SET AUPNX="9999"
+28 FOR I=1:1:4
Begin DoDot:1
+29 SET X=$EXTRACT(AUPNX,I)
+30 IF X<5
SET X=X+5
SET $EXTRACT(AUPNX,I)=X
IF 1
+31 IF '$TEST
SET X=X-5
SET $EXTRACT(AUPNX,I)=X
+32 QUIT
End DoDot:1
+33 SET AUPNV=AUPNV_AUPNX
+34 ;----------
+35 ; shuffle
+36 SET AUPNV=$EXTRACT(AUPNV,4,6)_$EXTRACT(AUPNV,10,12)_$EXTRACT(AUPNV,1,3)_$EXTRACT(AUPNV,7,9)
+37 ;----------
+38 ; encrypt
+39 DO ENCRYPT
+40 ;----------
ENCX ;
+1 QUIT AUPNV
+2 ;
+3 ;
ENCRYPT ;
+1 SET AUPNV=$TRANSLATE(AUPNV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
+2 SET AUPNV=$TRANSLATE(AUPNV,"1234567890","8967320415")
+3 QUIT
+4 ;
+5 ;
+6 ;
DEC(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
+1 NEW AUPNV,AUPNX,AUPNY,I,X,X1,Y
+2 SET AUPNV=""
+3 ; exit if no string
if $GET(PID)=""
GOTO DECX
+4 ; exit if string not 12 chars
if $LENGTH(PID)'=12
GOTO DECX
+5 SET AUPNV="["
+6 ;----------
+7 ; decrypt
+8 DO DECRYPT
+9 ;----------
+10 ; unshuffle
+11 SET PID=$EXTRACT(PID,7,9)_$EXTRACT(PID,1,3)_$EXTRACT(PID,10,12)_$EXTRACT(PID,4,6)
+12 ;----------
+13 ; take 1st 3 chars of name, replace numbers with punctuation
+14 SET AUPNX=""
+15 FOR I=3,2,1
SET AUPNX=AUPNX_$EXTRACT(PID,I)
+16 SET AUPNX=$TRANSLATE(AUPNX,"01234"," '-.,")
+17 SET AUPNY=""
+18 FOR I=1:1:3
if $EXTRACT(AUPNX,I)'="5"
SET AUPNY=AUPNY_$EXTRACT(AUPNX,I)
+19 SET AUPNX=AUPNY_","_$SELECT($EXTRACT(PID,4)'="0":$EXTRACT(PID,4),1:"")
+20 SET AUPNV=AUPNV_AUPNX
+21 ;----------
+22 ; fileman date of birth (converted to external format)
+23 SET AUPNX=""
+24 SET X=$EXTRACT(PID,5,8)
+25 FOR I=1:1:4
if $EXTRACT(X,I)'="-"
SET AUPNX=AUPNX_$EXTRACT(X,I)
+26 SET X=AUPNX
SET X1=16
DO DEC^XTBASE
SET AUPNX=Y
+27 SET AUPNX=$$HTE^XLFDT(AUPNX,1)
+28 SET AUPNV=AUPNV_"__"_AUPNX
+29 ;----------
+30 ; last 4 digits of SSN
+31 SET AUPNX=$EXTRACT(PID,9,12)
+32 FOR I=1:1:4
Begin DoDot:1
+33 SET X=$EXTRACT(AUPNX,I)
+34 IF X<5
SET X=X+5
SET $EXTRACT(AUPNX,I)=X
IF 1
+35 IF '$TEST
SET X=X-5
SET $EXTRACT(AUPNX,I)=X
+36 QUIT
End DoDot:1
+37 if AUPNX="9999"
SET AUPNX=" "
+38 SET AUPNV=AUPNV_"__"_AUPNX
+39 ;----------
+40 SET AUPNV=AUPNV_"]"
DECX ;
+1 QUIT AUPNV
+2 ;
DECRYPT ;
+1 SET PID=$TRANSLATE(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 SET PID=$TRANSLATE(PID,"8967320415","1234567890")
+3 QUIT
