source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNPAT4.m@ 1046

Last change on this file since 1046 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.0 KB
RevLine 
[613]1AUPNPAT4 ; IHS/CMI/LAB - ENCRYPTED PATIENT IDENTIFIER ;
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 22
3 ;
4 Q
5 ;
6 ; This routine is passed a patient ien and returns an encrypted patient
7 ; identifier 12 bytes long. The entry point DEC reverses the process
8 ; and returns the decoded output in a 27 byte long string.
9 ;
10ENC ;(DFN) ;EP - RETURN ENCRYPTED PATIENT IDENTIFIER
11 NEW AUPNV,AUPNX,AUPNY,I,X,X1,Y
12 S AUPNV=""
13 G:'$G(DFN) ENCX ; exit if no patient ien passed
14 G:'$D(^DPT(DFN,0)) ENCX ; exit if patient doesn't exist
15 ;----------
16 ; take 1st 3 chars of name, replace punctuation with numbers, pad out
17 ; to 3 chars
18 S AUPNX=$E($P($P(^DPT(DFN,0),U),","),1,3)
19 S AUPNX=$TR(AUPNX," '-.,","01234")
20 F I=1:1:(3-$L(AUPNX)) S AUPNX=AUPNX_"5"
21 S AUPNV=AUPNX
22 ;----------
23 ; take 1st initial, 0 if null
24 S AUPNX=$E($P($P(^DPT(DFN,0),U),",",2)) S:AUPNX="" AUPNX=0
25 ;----------
26 ; concatenate in reverse order
27 S AUPNV=$E(AUPNV,3)_$E(AUPNV,2)_$E(AUPNV)_AUPNX
28 ;----------
29 ; concatenate fileman date of birth (converted to $H/hex format)
30 S AUPNX=$$DOB^AUPNPAT(DFN) S:$L(AUPNX)'=7 AUPNX=3991231
31 S AUPNX=$$FMTH^XLFDT(AUPNX,1)
32 S X=AUPNX,X1=16 D CNV^XTBASE S Y=$E(Y,1,4)
33 F I=1:1:(4-$L(Y)) S Y=Y_"-"
34 S AUPNV=AUPNV_Y
35 ;----------
36 ; concatenate last 4 digits of SSN
37 S AUPNX=$E($$SSN^AUPNPAT(DFN),6,9) S:$L(AUPNX)'=4 AUPNX="9999"
38 F I=1:1:4 D
39 . S X=$E(AUPNX,I)
40 . I X<5 S X=X+5,$E(AUPNX,I)=X I 1
41 . E S X=X-5,$E(AUPNX,I)=X
42 . Q
43 S AUPNV=AUPNV_AUPNX
44 ;----------
45 ; shuffle
46 S AUPNV=$E(AUPNV,4,6)_$E(AUPNV,10,12)_$E(AUPNV,1,3)_$E(AUPNV,7,9)
47 ;----------
48 ; encrypt
49 D ENCRYPT
50 ;----------
51ENCX ;
52 Q AUPNV
53 ;
54 ;
55ENCRYPT ;
56 S AUPNV=$TR(AUPNV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
57 S AUPNV=$TR(AUPNV,"1234567890","8967320415")
58 Q
59 ;
60 ;
61 ;
62DEC ;(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
63 NEW AUPNV,AUPNX,AUPNY,I,X,X1,Y
64 S AUPNV=""
65 G:$G(PID)="" DECX ; exit if no string
66 G:$L(PID)'=12 DECX ; exit if string not 12 chars
67 S AUPNV="["
68 ;----------
69 ; decrypt
70 D DECRYPT
71 ;----------
72 ; unshuffle
73 S PID=$E(PID,7,9)_$E(PID,1,3)_$E(PID,10,12)_$E(PID,4,6)
74 ;----------
75 ; take 1st 3 chars of name, replace numbers with punctuation
76 S AUPNX=""
77 F I=3,2,1 S AUPNX=AUPNX_$E(PID,I)
78 S AUPNX=$TR(AUPNX,"01234"," '-.,")
79 S AUPNY=""
80 F I=1:1:3 S:$E(AUPNX,I)'="5" AUPNY=AUPNY_$E(AUPNX,I)
81 S AUPNX=AUPNY_","_$S($E(PID,4)'="0":$E(PID,4),1:"")
82 S AUPNV=AUPNV_AUPNX
83 ;----------
84 ; fileman date of birth (converted to external format)
85 S AUPNX=""
86 S X=$E(PID,5,8)
87 F I=1:1:4 S:$E(X,I)'="-" AUPNX=AUPNX_$E(X,I)
88 S X=AUPNX,X1=16 D DEC^XTBASE S AUPNX=Y
89 S AUPNX=$$HTE^XLFDT(AUPNX,1)
90 S AUPNV=AUPNV_"__"_AUPNX
91 ;----------
92 ; last 4 digits of SSN
93 S AUPNX=$E(PID,9,12)
94 F I=1:1:4 D
95 . S X=$E(AUPNX,I)
96 . I X<5 S X=X+5,$E(AUPNX,I)=X I 1
97 . E S X=X-5,$E(AUPNX,I)=X
98 . Q
99 S:AUPNX="9999" AUPNX=" "
100 S AUPNV=AUPNV_"__"_AUPNX
101 ;----------
102 S AUPNV=AUPNV_"]"
103DECX ;
104 Q AUPNV
105 ;
106DECRYPT ;
107 S PID=$TR(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
108 S PID=$TR(PID,"8967320415","1234567890")
109 Q
Note: See TracBrowser for help on using the repository browser.