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

AUPNPAT4.m

Go to the documentation of this file. 
  1. AUPNPAT4 ; IHS/CMI/LAB - ENCRYPTED PATIENT IDENTIFIER ;
  1.  ;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999
  1.  ;
  1.  Q
  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 AUPNV,AUPNX,AUPNY,I,X,X1,Y
  1.  S AUPNV=""
  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 AUPNX=$E($P($P(^DPT(DFN,0),U),","),1,3)
  1.  S AUPNX=$TR(AUPNX," '-.,","01234")
  1.  F I=1:1:(3-$L(AUPNX)) S AUPNX=AUPNX_"5"
  1.  S AUPNV=AUPNX
  1.  ;----------
  1.  ; take 1st initial, 0 if null
  1.  S AUPNX=$E($P($P(^DPT(DFN,0),U),",",2)) S:AUPNX="" AUPNX=0
  1.  ;----------
  1.  ; concatenate in reverse order
  1.  S AUPNV=$E(AUPNV,3)_$E(AUPNV,2)_$E(AUPNV)_AUPNX
  1.  ;----------
  1.  ; concatenate fileman date of birth (converted to $H/hex format)
  1.  S AUPNX=$$DOB^AUPNPAT(DFN) S:$L(AUPNX)'=7 AUPNX=3991231
  1.  S AUPNX=$$FMTH^XLFDT(AUPNX,1)
  1.  S X=AUPNX,X1=16 D CNV^XTBASE S Y=$E(Y,1,4)
  1.  F I=1:1:(4-$L(Y)) S Y=Y_"-"
  1.  S AUPNV=AUPNV_Y
  1.  ;----------
  1.  ; concatenate last 4 digits of SSN
  1.  S AUPNX=$E($$SSN^AUPNPAT(DFN),6,9) S:$L(AUPNX)'=4 AUPNX="9999"
  1.  F I=1:1:4 D
  1.  . S X=$E(AUPNX,I)
  1.  . I X<5 S X=X+5,$E(AUPNX,I)=X I 1
  1.  . E  S X=X-5,$E(AUPNX,I)=X
  1.  . Q
  1.  S AUPNV=AUPNV_AUPNX
  1.  ;----------
  1.  ; shuffle
  1.  S AUPNV=$E(AUPNV,4,6)_$E(AUPNV,10,12)_$E(AUPNV,1,3)_$E(AUPNV,7,9)
  1.  ;----------
  1.  ; encrypt
  1.  D ENCRYPT
  1.  ;----------
  1. ENCX ;
  1.  Q AUPNV
  1.  ;
  1.  ;
  1. ENCRYPT ;
  1.  S AUPNV=$TR(AUPNV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
  1.  S AUPNV=$TR(AUPNV,"1234567890","8967320415")
  1.  Q
  1.  ;
  1.  ;
  1.  ;
  1. DEC ;(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
  1.  NEW AUPNV,AUPNX,AUPNY,I,X,X1,Y
  1.  S AUPNV=""
  1.  G:$G(PID)="" DECX ;                     exit if no string
  1.  G:$L(PID)'=12 DECX ;                    exit if string not 12 chars
  1.  S AUPNV="["
  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 AUPNX=""
  1.  F I=3,2,1 S AUPNX=AUPNX_$E(PID,I)
  1.  S AUPNX=$TR(AUPNX,"01234"," '-.,")
  1.  S AUPNY=""
  1.  F I=1:1:3 S:$E(AUPNX,I)'="5" AUPNY=AUPNY_$E(AUPNX,I)
  1.  S AUPNX=AUPNY_","_$S($E(PID,4)'="0":$E(PID,4),1:"")
  1.  S AUPNV=AUPNV_AUPNX
  1.  ;----------
  1.  ; fileman date of birth (converted to external format)
  1.  S AUPNX=""
  1.  S X=$E(PID,5,8)
  1.  F I=1:1:4 S:$E(X,I)'="-" AUPNX=AUPNX_$E(X,I)
  1.  S X=AUPNX,X1=16 D DEC^XTBASE S AUPNX=Y
  1.  S AUPNX=$$HTE^XLFDT(AUPNX,1)
  1.  S AUPNV=AUPNV_"__"_AUPNX
  1.  ;----------
  1.  ; last 4 digits of SSN
  1.  S AUPNX=$E(PID,9,12)
  1.  F I=1:1:4 D
  1.  . S X=$E(AUPNX,I)
  1.  . I X<5 S X=X+5,$E(AUPNX,I)=X I 1
  1.  . E  S X=X-5,$E(AUPNX,I)=X
  1.  . Q
  1.  S:AUPNX="9999" AUPNX="    "
  1.  S AUPNV=AUPNV_"__"_AUPNX
  1.  ;----------
  1.  S AUPNV=AUPNV_"]"
  1. DECX ;
  1.  Q AUPNV
  1.  ;
  1. DECRYPT ;
  1.  S PID=$TR(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  S PID=$TR(PID,"8967320415","1234567890")
  1.  Q