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

ACDPID.m

Go to the documentation of this file. 
  1. ACDPID ;IHS/ADC/EDE/KML - ENCRYPTED PATIENT IDENTIFIER;
  1.  ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
  1.  ;
  1.  ; This routine is passed a patient ien and returns an encrypted patient
  1.  ; identifier 12 bytes long.  The entry point DEC reverses the process
  1.  ; and returns the decoded output in a 27 byte long string.
  1.  ;
  1. ENC(DFN) ;EP - RETURN ENCRYPTED PATIENT IDENTIFIER
  1.  NEW ACDV,ACDX,ACDY,I,X,X1,Y
  1.  S ACDV=""
  1.  G:'$G(DFN) ENCX ;                       exit if no patient ien passed
  1.  G:'$D(^DPT(DFN,0)) ENCX ;               exit if patient doesn't exist
  1.  ;----------
  1.  ; take 1st 3 chars of name, replace punctuation with numbers, pad out
  1.  ;   to 3 chars
  1.  S ACDX=$E($P($P(^DPT(DFN,0),U),","),1,3)
  1.  S ACDX=$TR(ACDX,"'-.,","1234")
  1.  F I=1:1:(3-$L(ACDX)) S ACDX=ACDX_"5"
  1.  S ACDV=ACDX
  1.  ;----------
  1.  ; take 1st initial, 0 if null
  1.  S ACDX=$E($P($P(^DPT(DFN,0),U),",",2)) S:ACDX="" ACDX=0
  1.  ;----------
  1.  ; concatenate in reverse order
  1.  S ACDV=$E(ACDV,3)_$E(ACDV,2)_$E(ACDV)_ACDX
  1.  ;----------
  1.  ; concatenate fileman date of birth (converted to $H/hex format)
  1.  S ACDX=$$DOB^AUPNPAT(DFN) S:$L(ACDX)'=7 ACDX=3991231
  1.  S ACDX=$$FMTH^XLFDT(ACDX,1)
  1.  S X=ACDX,X1=16 D CNV^XTBASE S Y=$E(Y,1,4)
  1.  F I=1:1:(4-$L(Y)) S Y=Y_"-"
  1.  S ACDV=ACDV_Y
  1.  ;----------
  1.  ; concatenate last 4 digits of SSN
  1.  S ACDX=$E($$SSN^AUPNPAT(DFN),6,9) S:$L(ACDX)'=4 ACDX="9999"
  1.  F I=1:1:4 D
  1.  . S X=$E(ACDX,I)
  1.  . I X<5 S X=X+5,$E(ACDX,I)=X I 1
  1.  . E  S X=X-5,$E(ACDX,I)=X
  1.  . Q
  1.  S ACDV=ACDV_ACDX
  1.  ;----------
  1.  ; shuffle
  1.  S ACDV=$E(ACDV,4,6)_$E(ACDV,10,12)_$E(ACDV,1,3)_$E(ACDV,7,9)
  1.  ;----------
  1.  ; encrypt
  1.  D ENCRYPT
  1.  ;----------
  1. ENCX ;
  1.  Q ACDV
  1.  ;
  1.  ;
  1. ENCRYPT ;
  1.  S ACDV=$TR(ACDV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
  1.  S ACDV=$TR(ACDV,"1234567890","8967320415")
  1.  Q
  1.  ;
  1.  ;
  1.  ;
  1. DEC(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
  1.  NEW ACDV,ACDX,ACDY,I,X,X1,Y
  1.  S ACDV=""
  1.  G:$G(PID)="" DECX ;                     exit if no string
  1.  G:$L(PID)'=12 DECX ;                    exit if string not 12 chars
  1.  S ACDV="["
  1.  ;----------
  1.  ; decrypt
  1.  D DECRYPT
  1.  ;----------
  1.  ; unshuffle
  1.  S PID=$E(PID,7,9)_$E(PID,1,3)_$E(PID,10,12)_$E(PID,4,6)
  1.  ;----------
  1.  ; take 1st 3 chars of name, replace numbers with punctuation
  1.  S ACDX=""
  1.  F I=3,2,1 S ACDX=ACDX_$E(PID,I)
  1.  S ACDX=$TR(ACDX,"1234","'-.,")
  1.  S ACDY=""
  1.  F I=1:1:3 S:$E(ACDX,I)'="5" ACDY=ACDY_$E(ACDX,I)
  1.  S ACDX=ACDY_","_$S($E(PID,4)'="0":$E(PID,4),1:"")
  1.  S ACDV=ACDV_ACDX
  1.  ;----------
  1.  ; fileman date of birth (converted to external format)
  1.  S ACDX=""
  1.  S X=$E(PID,5,8)
  1.  F I=1:1:4 S:$E(X,I)'="-" ACDX=ACDX_$E(X,I)
  1.  S X=ACDX,X1=16 D DEC^XTBASE S ACDX=Y
  1.  S ACDX=$$HTE^XLFDT(ACDX,1)
  1.  S ACDV=ACDV_"__"_ACDX
  1.  ;----------
  1.  ; last 4 digits of SSN
  1.  S ACDX=$E(PID,9,12)
  1.  F I=1:1:4 D
  1.  . S X=$E(ACDX,I)
  1.  . I X<5 S X=X+5,$E(ACDX,I)=X I 1
  1.  . E  S X=X-5,$E(ACDX,I)=X
  1.  . Q
  1.  S:ACDX="9999" ACDX="    "
  1.  S ACDV=ACDV_"__"_ACDX
  1.  ;----------
  1.  S ACDV=ACDV_"]"
  1. DECX ;
  1.  Q ACDV
  1.  ;
  1. DECRYPT ;
  1.  S PID=$TR(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  S PID=$TR(PID,"8967320415","1234567890")
  1.  Q