AMHRLU2 ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;ADDED ENCRYTION OF PATIENT ID TO THIS ROUTINE
;
;
COMM ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$D(^AMHREC(AMHY,0))
..Q:$P(^AMHREC(AMHY,0),U,5)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S X($P(^AUTTCOM($P(^AMHREC(AMHY,0),U,5),0),U))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
LOC ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$D(^AMHREC(AMHY,0))
..Q:$P(^AMHREC(AMHY,0),U,4)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S X($P(^AMHREC(AMHY,0),U,4))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
TOC ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$D(^AMHREC(AMHY,0))
..Q:$P(^AMHREC(AMHY,0),U,7)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S X($P(^AMHREC(AMHY,0),U,7))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
ASACOMP ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:$P($G(^AMHREC(AMHY,11)),U,1)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S X($P(^AMHREC(AMHY,11),U,1))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
AX4 ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..NEW % S %=0 F S %=$O(^AMHREC(AMHY,61,%)) Q:%'=+% S X($P(^AMHREC(AMHY,61,%,0),U))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
DRT ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:$P($G(^AMHREC(AMHY,11)),U,2)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S X($P(^AMHREC(AMHY,11),U,2))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
ASATOC ;
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$D(^AMHREC(AMHY,0))
..Q:$P(^AMHREC(AMHY,0),U,32)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S X($P(^AMHREC(AMHY,0),U,32))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
DAC ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:$P($G(^AMHREC(AMHY,11)),U,3)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S X($P(^AMHREC(AMHY,11),U,3))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
AX5 ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$D(^AMHREC(AMHY,0))
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..I $P(^AMHREC(AMHY,0),U,14)]"" S X($P(^AMHREC(AMHY,0),U,14))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
ACT ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$D(^AMHREC(AMHY,0))
..Q:$P(^AMHREC(AMHY,0),U,6)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S X($P(^AMHREC(AMHY,0),U,6))=""
..Q
.Q
Q
INPT ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$D(^AMHREC(AMHY,0))
..Q:$P(^AMHREC(AMHY,0),U,17)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S X($P(^AMHREC(AMHY,0),U,17))=""
..Q
.Q
K AMHZ,AMHY,AMHP Q
POV ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S AMHP=0 F S AMHP=$O(^AMHRPRO("AD",AMHY,AMHP)) Q:AMHP="" S X($P(^AMHRPRO(AMHP,0),U))=""
..Q
.Q
K AMHZ,AMHY,AMHP
Q
MHSS ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S AMHP=0 F S AMHP=$O(^AMHRPRO("AD",AMHY,AMHP)) Q:AMHP="" S X($P(^AMHPROB($P(^AMHRPRO(AMHP,0),U),0),U,3))=""
..Q
.Q
K AMHZ,AMHY,AMHP
Q
PROV ;EP
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S AMHP=0 F S AMHP=$O(^AMHRPROV("AD",AMHY,AMHP)) Q:AMHP="" S X($P(^AMHRPROV(AMHP,0),U))=""
..Q
.Q
K AMHZ,AMHY,AMHP
Q
; identifier 12 bytes long. The entry point DEC reverses the process
; and returns the decoded output in a 27 byte long string.
;
EDUC ;EP called from lister
S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
.S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
..S AMHP=0 F S AMHP=$O(^AMHREDU("AD",AMHY,AMHP)) Q:AMHP="" S X($P(^AMHREDU(AMHP,0),U))=""
..Q
.Q
K AMHZ,AMHY,AMHP
Q
HF ;EP
K AMHZ,AMHY,AMHP,X,AMHHFC,AMHHFC1
S AMHP=0 F S AMHP=$O(^AMHTRPT(AMHRPT,11,AMHI,11,"B",AMHP)) Q:AMHP="" D
.S AMHHFC=$P(^AUTTHF(AMHP,0),U,3)
.S AMHHFC(AMHHFC)=""
S AMHY=0 F S AMHY=$O(^AMHRHF("AC",DFN,AMHY)) Q:AMHY'=+AMHY D
.S AMHP=$P(^AMHRHF(AMHY,0),U)
.S AMHZ=$P(^AUTTHF(AMHP,0),U,3)
.Q:'$D(AMHHFC(AMHZ)) ;none in this category
.S AMHHFC1(AMHZ,(9999999-$P($P(^AMHREC($P(^AMHRHF(AMHY,0),U,3),0),U),".")))=AMHP
S AMHZ=0 F S AMHZ=$O(AMHHFC1(AMHZ)) Q:AMHZ'=+AMHZ D
.S AMHP=$O(AMHHFC1(AMHZ,0))
.S X(AMHHFC1(AMHZ,AMHP))=""
K AMHZ,AMHY,AMHP,AMHHFC,AMHHFC1
Q
HFP ;EP
K AMHZ,AMHY,AMHP,X,AMHHFC,AMHHFC1
S AMHY=0 F S AMHY=$O(^AMHRHF("AC",DFN,AMHY)) Q:AMHY'=+AMHY D
.S AMHP=$P(^AMHRHF(AMHY,0),U)
.S AMHZ=$P(^AUTTHF(AMHP,0),U,3)
.S AMHHFC1(AMHZ,(9999999-$P($P(^AMHREC($P(^AMHRHF(AMHY,0),U,3),0),U),".")))=AMHY
S AMHZ=0,AMHPCNT=0 F S AMHZ=$O(AMHHFC1(AMHZ)) Q:AMHZ'=+AMHZ D
.S AMHP=$O(AMHHFC1(AMHZ,0))
.S AMHY=AMHHFC1(AMHZ,AMHP)
.S AMHPCNT=AMHPCNT+1
.S V=$P(^AMHRHF(AMHY,0),U,3)
.S V=$P($P($G(^AMHREC(V,0)),U),".")
.S AMHPRNM(AMHPCNT)=$$VAL^XBDIQ1(9002011.08,AMHY,.01)_" - "_$E(V,4,5)_"/"_$E(V,6,7)_"/"_$E(V,2,3)
K AMHZ,AMHY,AMHP,AMHHFC,AMHHFC1
Q
ENC(DFN) ;EP - RETURN ENCRYPTED PATIENT IDENTIFIER
NEW AMHV,AMHX,AMHY,I,X,X1,Y
S AMHV=""
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 AMHX=$E($P($P(^DPT(DFN,0),U),","),1,3)
S AMHX=$TR(AMHX,"'-.,","1234")
F I=1:1:(3-$L(AMHX)) S AMHX=AMHX_"5"
S AMHV=AMHX
;----------
; take 1st initial, 0 if null
S AMHX=$E($P($P(^DPT(DFN,0),U),",",2)) S:AMHX="" AMHX=0
;----------
; concatenate in reverse order
S AMHV=$E(AMHV,3)_$E(AMHV,2)_$E(AMHV)_AMHX
;----------
; concatenate fileman date of birth (converted to $H/hex format)
S AMHX=$$DOB^AUPNPAT(DFN) S:$L(AMHX)'=7 AMHX=3991231
S AMHX=$$FMTH^XLFDT(AMHX,1)
S X=AMHX,X1=16 D CNV^XTBASE S Y=$E(Y,1,4)
F I=1:1:(4-$L(Y)) S Y=Y_"-"
S AMHV=AMHV_Y
;----------
; concatenate last 4 digits of SSN
S AMHX=$E($$SSN^AUPNPAT(DFN),6,9) S:$L(AMHX)'=4 AMHX="9999"
F I=1:1:4 D
. S X=$E(AMHX,I)
. I X<5 S X=X+5,$E(AMHX,I)=X I 1
. E S X=X-5,$E(AMHX,I)=X
. Q
S AMHV=AMHV_AMHX
;----------
; shuffle
S AMHV=$E(AMHV,4,6)_$E(AMHV,10,12)_$E(AMHV,1,3)_$E(AMHV,7,9)
;----------
; encrypt
D ENCRYPT
;----------
ENCX ;
Q AMHV
;
;
ENCRYPT ;
S AMHV=$TR(AMHV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
S AMHV=$TR(AMHV,"1234567890","8967320415")
Q
;
;
;
DEC(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
NEW AMHV,AMHX,AMHY,I,X,X1,Y
S AMHV=""
G:$G(PID)="" DECX ; exit if no string
G:$L(PID)'=12 DECX ; exit if string not 12 chars
S AMHV="["
;----------
; 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 AMHX=""
F I=3,2,1 S AMHX=AMHX_$E(PID,I)
S AMHX=$TR(AMHX,"1234","'-.,")
S AMHY=""
F I=1:1:3 S:$E(AMHX,I)'="5" AMHY=AMHY_$E(AMHX,I)
S AMHX=AMHY_","_$S($E(PID,4)'="0":$E(PID,4),1:"")
S AMHV=AMHV_AMHX
;----------
; fileman date of birth (converted to external format)
S AMHX=""
S X=$E(PID,5,8)
F I=1:1:4 S:$E(X,I)'="-" AMHX=AMHX_$E(X,I)
S X=AMHX,X1=16 D DEC^XTBASE S AMHX=Y
S AMHX=$$HTE^XLFDT(AMHX,1)
S AMHV=AMHV_"__"_AMHX
;----------
; last 4 digits of SSN
S AMHX=$E(PID,9,12)
F I=1:1:4 D
. S X=$E(AMHX,I)
. I X<5 S X=X+5,$E(AMHX,I)=X I 1
. E S X=X-5,$E(AMHX,I)=X
. Q
S:AMHX="9999" AMHX=" "
S AMHV=AMHV_"__"_AMHX
;----------
S AMHV=AMHV_"]"
DECX ;
Q AMHV
;
DECRYPT ;
S PID=$TR(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S PID=$TR(PID,"8967320415","1234567890")
Q
AMHRLU2 ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;ADDED ENCRYTION OF PATIENT ID TO THIS ROUTINE
+3 ;
+4 ;
COMM ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$DATA(^AMHREC(AMHY,0))
QUIT
+4 IF $PIECE(^AMHREC(AMHY,0),U,5)=""
QUIT
+5 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+6 SET X($PIECE(^AUTTCOM($PIECE(^AMHREC(AMHY,0),U,5),0),U))=""
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 KILL AMHZ,AMHY,AMHP
QUIT
LOC ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$DATA(^AMHREC(AMHY,0))
QUIT
+4 IF $PIECE(^AMHREC(AMHY,0),U,4)=""
QUIT
+5 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+6 SET X($PIECE(^AMHREC(AMHY,0),U,4))=""
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 KILL AMHZ,AMHY,AMHP
QUIT
TOC ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$DATA(^AMHREC(AMHY,0))
QUIT
+4 IF $PIECE(^AMHREC(AMHY,0),U,7)=""
QUIT
+5 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+6 SET X($PIECE(^AMHREC(AMHY,0),U,7))=""
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 KILL AMHZ,AMHY,AMHP
QUIT
ASACOMP ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF $PIECE($GET(^AMHREC(AMHY,11)),U,1)=""
QUIT
+4 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+5 SET X($PIECE(^AMHREC(AMHY,11),U,1))=""
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 KILL AMHZ,AMHY,AMHP
QUIT
AX4 ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+4 NEW %
SET %=0
FOR
SET %=$ORDER(^AMHREC(AMHY,61,%))
IF %'=+%
QUIT
SET X($PIECE(^AMHREC(AMHY,61,%,0),U))=""
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 KILL AMHZ,AMHY,AMHP
QUIT
DRT ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF $PIECE($GET(^AMHREC(AMHY,11)),U,2)=""
QUIT
+4 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+5 SET X($PIECE(^AMHREC(AMHY,11),U,2))=""
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 KILL AMHZ,AMHY,AMHP
QUIT
ASATOC ;
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$DATA(^AMHREC(AMHY,0))
QUIT
+4 IF $PIECE(^AMHREC(AMHY,0),U,32)=""
QUIT
+5 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+6 SET X($PIECE(^AMHREC(AMHY,0),U,32))=""
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 KILL AMHZ,AMHY,AMHP
QUIT
DAC ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF $PIECE($GET(^AMHREC(AMHY,11)),U,3)=""
QUIT
+4 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+5 SET X($PIECE(^AMHREC(AMHY,11),U,3))=""
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 KILL AMHZ,AMHY,AMHP
QUIT
AX5 ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$DATA(^AMHREC(AMHY,0))
QUIT
+4 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+5 IF $PIECE(^AMHREC(AMHY,0),U,14)]""
SET X($PIECE(^AMHREC(AMHY,0),U,14))=""
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 KILL AMHZ,AMHY,AMHP
QUIT
ACT ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$DATA(^AMHREC(AMHY,0))
QUIT
+4 IF $PIECE(^AMHREC(AMHY,0),U,6)=""
QUIT
+5 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+6 SET X($PIECE(^AMHREC(AMHY,0),U,6))=""
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
INPT ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$DATA(^AMHREC(AMHY,0))
QUIT
+4 IF $PIECE(^AMHREC(AMHY,0),U,17)=""
QUIT
+5 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+6 SET X($PIECE(^AMHREC(AMHY,0),U,17))=""
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 KILL AMHZ,AMHY,AMHP
QUIT
POV ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+4 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHRPRO("AD",AMHY,AMHP))
IF AMHP=""
QUIT
SET X($PIECE(^AMHRPRO(AMHP,0),U))=""
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 KILL AMHZ,AMHY,AMHP
+8 QUIT
MHSS ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+4 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHRPRO("AD",AMHY,AMHP))
IF AMHP=""
QUIT
SET X($PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHP,0),U),0),U,3))=""
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 KILL AMHZ,AMHY,AMHP
+8 QUIT
PROV ;EP
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+4 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHRPROV("AD",AMHY,AMHP))
IF AMHP=""
QUIT
SET X($PIECE(^AMHRPROV(AMHP,0),U))=""
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 KILL AMHZ,AMHY,AMHP
+8 QUIT
+9 ; identifier 12 bytes long. The entry point DEC reverses the process
+10 ; and returns the decoded output in a 27 byte long string.
+11 ;
EDUC ;EP called from lister
+1 SET AMHZ=AMHSD
FOR
SET AMHZ=$ORDER(^AMHREC("AF",DFN,AMHZ))
IF AMHZ=""!($PIECE(AMHZ,".")>AMHED)
QUIT
Begin DoDot:1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHREC("AF",DFN,AMHZ,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+3 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHY)
QUIT
+4 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHREDU("AD",AMHY,AMHP))
IF AMHP=""
QUIT
SET X($PIECE(^AMHREDU(AMHP,0),U))=""
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 KILL AMHZ,AMHY,AMHP
+8 QUIT
HF ;EP
+1 KILL AMHZ,AMHY,AMHP,X,AMHHFC,AMHHFC1
+2 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHTRPT(AMHRPT,11,AMHI,11,"B",AMHP))
IF AMHP=""
QUIT
Begin DoDot:1
+3 SET AMHHFC=$PIECE(^AUTTHF(AMHP,0),U,3)
+4 SET AMHHFC(AMHHFC)=""
End DoDot:1
+5 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHRHF("AC",DFN,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:1
+6 SET AMHP=$PIECE(^AMHRHF(AMHY,0),U)
+7 SET AMHZ=$PIECE(^AUTTHF(AMHP,0),U,3)
+8 ;none in this category
IF '$DATA(AMHHFC(AMHZ))
QUIT
+9 SET AMHHFC1(AMHZ,(9999999-$PIECE($PIECE(^AMHREC($PIECE(^AMHRHF(AMHY,0),U,3),0),U),".")))=AMHP
End DoDot:1
+10 SET AMHZ=0
FOR
SET AMHZ=$ORDER(AMHHFC1(AMHZ))
IF AMHZ'=+AMHZ
QUIT
Begin DoDot:1
+11 SET AMHP=$ORDER(AMHHFC1(AMHZ,0))
+12 SET X(AMHHFC1(AMHZ,AMHP))=""
End DoDot:1
+13 KILL AMHZ,AMHY,AMHP,AMHHFC,AMHHFC1
+14 QUIT
HFP ;EP
+1 KILL AMHZ,AMHY,AMHP,X,AMHHFC,AMHHFC1
+2 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHRHF("AC",DFN,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:1
+3 SET AMHP=$PIECE(^AMHRHF(AMHY,0),U)
+4 SET AMHZ=$PIECE(^AUTTHF(AMHP,0),U,3)
+5 SET AMHHFC1(AMHZ,(9999999-$PIECE($PIECE(^AMHREC($PIECE(^AMHRHF(AMHY,0),U,3),0),U),".")))=AMHY
End DoDot:1
+6 SET AMHZ=0
SET AMHPCNT=0
FOR
SET AMHZ=$ORDER(AMHHFC1(AMHZ))
IF AMHZ'=+AMHZ
QUIT
Begin DoDot:1
+7 SET AMHP=$ORDER(AMHHFC1(AMHZ,0))
+8 SET AMHY=AMHHFC1(AMHZ,AMHP)
+9 SET AMHPCNT=AMHPCNT+1
+10 SET V=$PIECE(^AMHRHF(AMHY,0),U,3)
+11 SET V=$PIECE($PIECE($GET(^AMHREC(V,0)),U),".")
+12 SET AMHPRNM(AMHPCNT)=$$VAL^XBDIQ1(9002011.08,AMHY,.01)_" - "_$EXTRACT(V,4,5)_"/"_$EXTRACT(V,6,7)_"/"_$EXTRACT(V,2,3)
End DoDot:1
+13 KILL AMHZ,AMHY,AMHP,AMHHFC,AMHHFC1
+14 QUIT
ENC(DFN) ;EP - RETURN ENCRYPTED PATIENT IDENTIFIER
+1 NEW AMHV,AMHX,AMHY,I,X,X1,Y
+2 SET AMHV=""
+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 AMHX=$EXTRACT($PIECE($PIECE(^DPT(DFN,0),U),","),1,3)
+9 SET AMHX=$TRANSLATE(AMHX,"'-.,","1234")
+10 FOR I=1:1:(3-$LENGTH(AMHX))
SET AMHX=AMHX_"5"
+11 SET AMHV=AMHX
+12 ;----------
+13 ; take 1st initial, 0 if null
+14 SET AMHX=$EXTRACT($PIECE($PIECE(^DPT(DFN,0),U),",",2))
IF AMHX=""
SET AMHX=0
+15 ;----------
+16 ; concatenate in reverse order
+17 SET AMHV=$EXTRACT(AMHV,3)_$EXTRACT(AMHV,2)_$EXTRACT(AMHV)_AMHX
+18 ;----------
+19 ; concatenate fileman date of birth (converted to $H/hex format)
+20 SET AMHX=$$DOB^AUPNPAT(DFN)
IF $LENGTH(AMHX)'=7
SET AMHX=3991231
+21 SET AMHX=$$FMTH^XLFDT(AMHX,1)
+22 SET X=AMHX
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 AMHV=AMHV_Y
+25 ;----------
+26 ; concatenate last 4 digits of SSN
+27 SET AMHX=$EXTRACT($$SSN^AUPNPAT(DFN),6,9)
IF $LENGTH(AMHX)'=4
SET AMHX="9999"
+28 FOR I=1:1:4
Begin DoDot:1
+29 SET X=$EXTRACT(AMHX,I)
+30 IF X<5
SET X=X+5
SET $EXTRACT(AMHX,I)=X
IF 1
+31 IF '$TEST
SET X=X-5
SET $EXTRACT(AMHX,I)=X
+32 QUIT
End DoDot:1
+33 SET AMHV=AMHV_AMHX
+34 ;----------
+35 ; shuffle
+36 SET AMHV=$EXTRACT(AMHV,4,6)_$EXTRACT(AMHV,10,12)_$EXTRACT(AMHV,1,3)_$EXTRACT(AMHV,7,9)
+37 ;----------
+38 ; encrypt
+39 DO ENCRYPT
+40 ;----------
ENCX ;
+1 QUIT AMHV
+2 ;
+3 ;
ENCRYPT ;
+1 SET AMHV=$TRANSLATE(AMHV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
+2 SET AMHV=$TRANSLATE(AMHV,"1234567890","8967320415")
+3 QUIT
+4 ;
+5 ;
+6 ;
DEC(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
+1 NEW AMHV,AMHX,AMHY,I,X,X1,Y
+2 SET AMHV=""
+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 AMHV="["
+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 AMHX=""
+15 FOR I=3,2,1
SET AMHX=AMHX_$EXTRACT(PID,I)
+16 SET AMHX=$TRANSLATE(AMHX,"1234","'-.,")
+17 SET AMHY=""
+18 FOR I=1:1:3
IF $EXTRACT(AMHX,I)'="5"
SET AMHY=AMHY_$EXTRACT(AMHX,I)
+19 SET AMHX=AMHY_","_$SELECT($EXTRACT(PID,4)'="0":$EXTRACT(PID,4),1:"")
+20 SET AMHV=AMHV_AMHX
+21 ;----------
+22 ; fileman date of birth (converted to external format)
+23 SET AMHX=""
+24 SET X=$EXTRACT(PID,5,8)
+25 FOR I=1:1:4
IF $EXTRACT(X,I)'="-"
SET AMHX=AMHX_$EXTRACT(X,I)
+26 SET X=AMHX
SET X1=16
DO DEC^XTBASE
SET AMHX=Y
+27 SET AMHX=$$HTE^XLFDT(AMHX,1)
+28 SET AMHV=AMHV_"__"_AMHX
+29 ;----------
+30 ; last 4 digits of SSN
+31 SET AMHX=$EXTRACT(PID,9,12)
+32 FOR I=1:1:4
Begin DoDot:1
+33 SET X=$EXTRACT(AMHX,I)
+34 IF X<5
SET X=X+5
SET $EXTRACT(AMHX,I)=X
IF 1
+35 IF '$TEST
SET X=X-5
SET $EXTRACT(AMHX,I)=X
+36 QUIT
End DoDot:1
+37 IF AMHX="9999"
SET AMHX=" "
+38 SET AMHV=AMHV_"__"_AMHX
+39 ;----------
+40 SET AMHV=AMHV_"]"
DECX ;
+1 QUIT AMHV
+2 ;
DECRYPT ;
+1 SET PID=$TRANSLATE(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 SET PID=$TRANSLATE(PID,"8967320415","1234567890")
+3 QUIT
