ACDPID ;IHS/ADC/EDE/KML - ENCRYPTED PATIENT IDENTIFIER;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
; 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 ACDV,ACDX,ACDY,I,X,X1,Y
S ACDV=""
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 ACDX=$E($P($P(^DPT(DFN,0),U),","),1,3)
S ACDX=$TR(ACDX,"'-.,","1234")
F I=1:1:(3-$L(ACDX)) S ACDX=ACDX_"5"
S ACDV=ACDX
;----------
; take 1st initial, 0 if null
S ACDX=$E($P($P(^DPT(DFN,0),U),",",2)) S:ACDX="" ACDX=0
;----------
; concatenate in reverse order
S ACDV=$E(ACDV,3)_$E(ACDV,2)_$E(ACDV)_ACDX
;----------
; concatenate fileman date of birth (converted to $H/hex format)
S ACDX=$$DOB^AUPNPAT(DFN) S:$L(ACDX)'=7 ACDX=3991231
S ACDX=$$FMTH^XLFDT(ACDX,1)
S X=ACDX,X1=16 D CNV^XTBASE S Y=$E(Y,1,4)
F I=1:1:(4-$L(Y)) S Y=Y_"-"
S ACDV=ACDV_Y
;----------
; concatenate last 4 digits of SSN
S ACDX=$E($$SSN^AUPNPAT(DFN),6,9) S:$L(ACDX)'=4 ACDX="9999"
F I=1:1:4 D
. S X=$E(ACDX,I)
. I X<5 S X=X+5,$E(ACDX,I)=X I 1
. E S X=X-5,$E(ACDX,I)=X
. Q
S ACDV=ACDV_ACDX
;----------
; shuffle
S ACDV=$E(ACDV,4,6)_$E(ACDV,10,12)_$E(ACDV,1,3)_$E(ACDV,7,9)
;----------
; encrypt
D ENCRYPT
;----------
ENCX ;
Q ACDV
;
;
ENCRYPT ;
S ACDV=$TR(ACDV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
S ACDV=$TR(ACDV,"1234567890","8967320415")
Q
;
;
;
DEC(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
NEW ACDV,ACDX,ACDY,I,X,X1,Y
S ACDV=""
G:$G(PID)="" DECX ; exit if no string
G:$L(PID)'=12 DECX ; exit if string not 12 chars
S ACDV="["
;----------
; 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 ACDX=""
F I=3,2,1 S ACDX=ACDX_$E(PID,I)
S ACDX=$TR(ACDX,"1234","'-.,")
S ACDY=""
F I=1:1:3 S:$E(ACDX,I)'="5" ACDY=ACDY_$E(ACDX,I)
S ACDX=ACDY_","_$S($E(PID,4)'="0":$E(PID,4),1:"")
S ACDV=ACDV_ACDX
;----------
; fileman date of birth (converted to external format)
S ACDX=""
S X=$E(PID,5,8)
F I=1:1:4 S:$E(X,I)'="-" ACDX=ACDX_$E(X,I)
S X=ACDX,X1=16 D DEC^XTBASE S ACDX=Y
S ACDX=$$HTE^XLFDT(ACDX,1)
S ACDV=ACDV_"__"_ACDX
;----------
; last 4 digits of SSN
S ACDX=$E(PID,9,12)
F I=1:1:4 D
. S X=$E(ACDX,I)
. I X<5 S X=X+5,$E(ACDX,I)=X I 1
. E S X=X-5,$E(ACDX,I)=X
. Q
S:ACDX="9999" ACDX=" "
S ACDV=ACDV_"__"_ACDX
;----------
S ACDV=ACDV_"]"
DECX ;
Q ACDV
;
DECRYPT ;
S PID=$TR(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S PID=$TR(PID,"8967320415","1234567890")
Q
ACDPID ;IHS/ADC/EDE/KML - ENCRYPTED PATIENT IDENTIFIER;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
+3 ; This routine is passed a patient ien and returns an encrypted patient
+4 ; identifier 12 bytes long. The entry point DEC reverses the process
+5 ; and returns the decoded output in a 27 byte long string.
+6 ;
ENC(DFN) ;EP - RETURN ENCRYPTED PATIENT IDENTIFIER
+1 NEW ACDV,ACDX,ACDY,I,X,X1,Y
+2 SET ACDV=""
+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 ACDX=$EXTRACT($PIECE($PIECE(^DPT(DFN,0),U),","),1,3)
+9 SET ACDX=$TRANSLATE(ACDX,"'-.,","1234")
+10 FOR I=1:1:(3-$LENGTH(ACDX))
SET ACDX=ACDX_"5"
+11 SET ACDV=ACDX
+12 ;----------
+13 ; take 1st initial, 0 if null
+14 SET ACDX=$EXTRACT($PIECE($PIECE(^DPT(DFN,0),U),",",2))
IF ACDX=""
SET ACDX=0
+15 ;----------
+16 ; concatenate in reverse order
+17 SET ACDV=$EXTRACT(ACDV,3)_$EXTRACT(ACDV,2)_$EXTRACT(ACDV)_ACDX
+18 ;----------
+19 ; concatenate fileman date of birth (converted to $H/hex format)
+20 SET ACDX=$$DOB^AUPNPAT(DFN)
IF $LENGTH(ACDX)'=7
SET ACDX=3991231
+21 SET ACDX=$$FMTH^XLFDT(ACDX,1)
+22 SET X=ACDX
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 ACDV=ACDV_Y
+25 ;----------
+26 ; concatenate last 4 digits of SSN
+27 SET ACDX=$EXTRACT($$SSN^AUPNPAT(DFN),6,9)
IF $LENGTH(ACDX)'=4
SET ACDX="9999"
+28 FOR I=1:1:4
Begin DoDot:1
+29 SET X=$EXTRACT(ACDX,I)
+30 IF X<5
SET X=X+5
SET $EXTRACT(ACDX,I)=X
IF 1
+31 IF '$TEST
SET X=X-5
SET $EXTRACT(ACDX,I)=X
+32 QUIT
End DoDot:1
+33 SET ACDV=ACDV_ACDX
+34 ;----------
+35 ; shuffle
+36 SET ACDV=$EXTRACT(ACDV,4,6)_$EXTRACT(ACDV,10,12)_$EXTRACT(ACDV,1,3)_$EXTRACT(ACDV,7,9)
+37 ;----------
+38 ; encrypt
+39 DO ENCRYPT
+40 ;----------
ENCX ;
+1 QUIT ACDV
+2 ;
+3 ;
ENCRYPT ;
+1 SET ACDV=$TRANSLATE(ACDV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
+2 SET ACDV=$TRANSLATE(ACDV,"1234567890","8967320415")
+3 QUIT
+4 ;
+5 ;
+6 ;
DEC(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
+1 NEW ACDV,ACDX,ACDY,I,X,X1,Y
+2 SET ACDV=""
+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 ACDV="["
+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 ACDX=""
+15 FOR I=3,2,1
SET ACDX=ACDX_$EXTRACT(PID,I)
+16 SET ACDX=$TRANSLATE(ACDX,"1234","'-.,")
+17 SET ACDY=""
+18 FOR I=1:1:3
IF $EXTRACT(ACDX,I)'="5"
SET ACDY=ACDY_$EXTRACT(ACDX,I)
+19 SET ACDX=ACDY_","_$SELECT($EXTRACT(PID,4)'="0":$EXTRACT(PID,4),1:"")
+20 SET ACDV=ACDV_ACDX
+21 ;----------
+22 ; fileman date of birth (converted to external format)
+23 SET ACDX=""
+24 SET X=$EXTRACT(PID,5,8)
+25 FOR I=1:1:4
IF $EXTRACT(X,I)'="-"
SET ACDX=ACDX_$EXTRACT(X,I)
+26 SET X=ACDX
SET X1=16
DO DEC^XTBASE
SET ACDX=Y
+27 SET ACDX=$$HTE^XLFDT(ACDX,1)
+28 SET ACDV=ACDV_"__"_ACDX
+29 ;----------
+30 ; last 4 digits of SSN
+31 SET ACDX=$EXTRACT(PID,9,12)
+32 FOR I=1:1:4
Begin DoDot:1
+33 SET X=$EXTRACT(ACDX,I)
+34 IF X<5
SET X=X+5
SET $EXTRACT(ACDX,I)=X
IF 1
+35 IF '$TEST
SET X=X-5
SET $EXTRACT(ACDX,I)=X
+36 QUIT
End DoDot:1
+37 IF ACDX="9999"
SET ACDX=" "
+38 SET ACDV=ACDV_"__"_ACDX
+39 ;----------
+40 SET ACDV=ACDV_"]"
DECX ;
+1 QUIT ACDV
+2 ;
DECRYPT ;
+1 SET PID=$TRANSLATE(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 SET PID=$TRANSLATE(PID,"8967320415","1234567890")
+3 QUIT
