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

AMHRLU2.m

Go to the documentation of this file.
  1. AMHRLU2 ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
  1. ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
  1. ;ADDED ENCRYTION OF PATIENT ID TO THIS ROUTINE
  1. ;
  1. ;
  1. COMM ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$D(^AMHREC(AMHY,0))
  1. ..Q:$P(^AMHREC(AMHY,0),U,5)=""
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S X($P(^AUTTCOM($P(^AMHREC(AMHY,0),U,5),0),U))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. LOC ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$D(^AMHREC(AMHY,0))
  1. ..Q:$P(^AMHREC(AMHY,0),U,4)=""
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S X($P(^AMHREC(AMHY,0),U,4))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. TOC ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$D(^AMHREC(AMHY,0))
  1. ..Q:$P(^AMHREC(AMHY,0),U,7)=""
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S X($P(^AMHREC(AMHY,0),U,7))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. ASACOMP ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:$P($G(^AMHREC(AMHY,11)),U,1)=""
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S X($P(^AMHREC(AMHY,11),U,1))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. AX4 ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..NEW % S %=0 F S %=$O(^AMHREC(AMHY,61,%)) Q:%'=+% S X($P(^AMHREC(AMHY,61,%,0),U))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. DRT ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:$P($G(^AMHREC(AMHY,11)),U,2)=""
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S X($P(^AMHREC(AMHY,11),U,2))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. ASATOC ;
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$D(^AMHREC(AMHY,0))
  1. ..Q:$P(^AMHREC(AMHY,0),U,32)=""
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S X($P(^AMHREC(AMHY,0),U,32))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. DAC ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:$P($G(^AMHREC(AMHY,11)),U,3)=""
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S X($P(^AMHREC(AMHY,11),U,3))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. AX5 ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$D(^AMHREC(AMHY,0))
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..I $P(^AMHREC(AMHY,0),U,14)]"" S X($P(^AMHREC(AMHY,0),U,14))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. ACT ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$D(^AMHREC(AMHY,0))
  1. ..Q:$P(^AMHREC(AMHY,0),U,6)=""
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S X($P(^AMHREC(AMHY,0),U,6))=""
  1. ..Q
  1. .Q
  1. Q
  1. INPT ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$D(^AMHREC(AMHY,0))
  1. ..Q:$P(^AMHREC(AMHY,0),U,17)=""
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S X($P(^AMHREC(AMHY,0),U,17))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP Q
  1. POV ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S AMHP=0 F S AMHP=$O(^AMHRPRO("AD",AMHY,AMHP)) Q:AMHP="" S X($P(^AMHRPRO(AMHP,0),U))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP
  1. Q
  1. MHSS ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..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))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP
  1. Q
  1. PROV ;EP
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S AMHP=0 F S AMHP=$O(^AMHRPROV("AD",AMHY,AMHP)) Q:AMHP="" S X($P(^AMHRPROV(AMHP,0),U))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP
  1. Q
  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. EDUC ;EP called from lister
  1. S AMHZ=AMHSD F S AMHZ=$O(^AMHREC("AF",DFN,AMHZ)) Q:AMHZ=""!($P(AMHZ,".")>AMHED) D
  1. .S AMHY=0 F S AMHY=$O(^AMHREC("AF",DFN,AMHZ,AMHY)) Q:AMHY'=+AMHY D
  1. ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHY)
  1. ..S AMHP=0 F S AMHP=$O(^AMHREDU("AD",AMHY,AMHP)) Q:AMHP="" S X($P(^AMHREDU(AMHP,0),U))=""
  1. ..Q
  1. .Q
  1. K AMHZ,AMHY,AMHP
  1. Q
  1. HF ;EP
  1. K AMHZ,AMHY,AMHP,X,AMHHFC,AMHHFC1
  1. S AMHP=0 F S AMHP=$O(^AMHTRPT(AMHRPT,11,AMHI,11,"B",AMHP)) Q:AMHP="" D
  1. .S AMHHFC=$P(^AUTTHF(AMHP,0),U,3)
  1. .S AMHHFC(AMHHFC)=""
  1. S AMHY=0 F S AMHY=$O(^AMHRHF("AC",DFN,AMHY)) Q:AMHY'=+AMHY D
  1. .S AMHP=$P(^AMHRHF(AMHY,0),U)
  1. .S AMHZ=$P(^AUTTHF(AMHP,0),U,3)
  1. .Q:'$D(AMHHFC(AMHZ)) ;none in this category
  1. .S AMHHFC1(AMHZ,(9999999-$P($P(^AMHREC($P(^AMHRHF(AMHY,0),U,3),0),U),".")))=AMHP
  1. S AMHZ=0 F S AMHZ=$O(AMHHFC1(AMHZ)) Q:AMHZ'=+AMHZ D
  1. .S AMHP=$O(AMHHFC1(AMHZ,0))
  1. .S X(AMHHFC1(AMHZ,AMHP))=""
  1. K AMHZ,AMHY,AMHP,AMHHFC,AMHHFC1
  1. Q
  1. HFP ;EP
  1. K AMHZ,AMHY,AMHP,X,AMHHFC,AMHHFC1
  1. S AMHY=0 F S AMHY=$O(^AMHRHF("AC",DFN,AMHY)) Q:AMHY'=+AMHY D
  1. .S AMHP=$P(^AMHRHF(AMHY,0),U)
  1. .S AMHZ=$P(^AUTTHF(AMHP,0),U,3)
  1. .S AMHHFC1(AMHZ,(9999999-$P($P(^AMHREC($P(^AMHRHF(AMHY,0),U,3),0),U),".")))=AMHY
  1. S AMHZ=0,AMHPCNT=0 F S AMHZ=$O(AMHHFC1(AMHZ)) Q:AMHZ'=+AMHZ D
  1. .S AMHP=$O(AMHHFC1(AMHZ,0))
  1. .S AMHY=AMHHFC1(AMHZ,AMHP)
  1. .S AMHPCNT=AMHPCNT+1
  1. .S V=$P(^AMHRHF(AMHY,0),U,3)
  1. .S V=$P($P($G(^AMHREC(V,0)),U),".")
  1. .S AMHPRNM(AMHPCNT)=$$VAL^XBDIQ1(9002011.08,AMHY,.01)_" - "_$E(V,4,5)_"/"_$E(V,6,7)_"/"_$E(V,2,3)
  1. K AMHZ,AMHY,AMHP,AMHHFC,AMHHFC1
  1. Q
  1. ENC(DFN) ;EP - RETURN ENCRYPTED PATIENT IDENTIFIER
  1. NEW AMHV,AMHX,AMHY,I,X,X1,Y
  1. S AMHV=""
  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 AMHX=$E($P($P(^DPT(DFN,0),U),","),1,3)
  1. S AMHX=$TR(AMHX,"'-.,","1234")
  1. F I=1:1:(3-$L(AMHX)) S AMHX=AMHX_"5"
  1. S AMHV=AMHX
  1. ;----------
  1. ; take 1st initial, 0 if null
  1. S AMHX=$E($P($P(^DPT(DFN,0),U),",",2)) S:AMHX="" AMHX=0
  1. ;----------
  1. ; concatenate in reverse order
  1. S AMHV=$E(AMHV,3)_$E(AMHV,2)_$E(AMHV)_AMHX
  1. ;----------
  1. ; concatenate fileman date of birth (converted to $H/hex format)
  1. S AMHX=$$DOB^AUPNPAT(DFN) S:$L(AMHX)'=7 AMHX=3991231
  1. S AMHX=$$FMTH^XLFDT(AMHX,1)
  1. S X=AMHX,X1=16 D CNV^XTBASE S Y=$E(Y,1,4)
  1. F I=1:1:(4-$L(Y)) S Y=Y_"-"
  1. S AMHV=AMHV_Y
  1. ;----------
  1. ; concatenate last 4 digits of SSN
  1. S AMHX=$E($$SSN^AUPNPAT(DFN),6,9) S:$L(AMHX)'=4 AMHX="9999"
  1. F I=1:1:4 D
  1. . S X=$E(AMHX,I)
  1. . I X<5 S X=X+5,$E(AMHX,I)=X I 1
  1. . E S X=X-5,$E(AMHX,I)=X
  1. . Q
  1. S AMHV=AMHV_AMHX
  1. ;----------
  1. ; shuffle
  1. S AMHV=$E(AMHV,4,6)_$E(AMHV,10,12)_$E(AMHV,1,3)_$E(AMHV,7,9)
  1. ;----------
  1. ; encrypt
  1. D ENCRYPT
  1. ;----------
  1. ENCX ;
  1. Q AMHV
  1. ;
  1. ;
  1. ENCRYPT ;
  1. S AMHV=$TR(AMHV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
  1. S AMHV=$TR(AMHV,"1234567890","8967320415")
  1. Q
  1. ;
  1. ;
  1. ;
  1. DEC(PID) ;EP - RETURN DECRYPTED PATIENT IDENTIFIER
  1. NEW AMHV,AMHX,AMHY,I,X,X1,Y
  1. S AMHV=""
  1. G:$G(PID)="" DECX ; exit if no string
  1. G:$L(PID)'=12 DECX ; exit if string not 12 chars
  1. S AMHV="["
  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 AMHX=""
  1. F I=3,2,1 S AMHX=AMHX_$E(PID,I)
  1. S AMHX=$TR(AMHX,"1234","'-.,")
  1. S AMHY=""
  1. F I=1:1:3 S:$E(AMHX,I)'="5" AMHY=AMHY_$E(AMHX,I)
  1. S AMHX=AMHY_","_$S($E(PID,4)'="0":$E(PID,4),1:"")
  1. S AMHV=AMHV_AMHX
  1. ;----------
  1. ; fileman date of birth (converted to external format)
  1. S AMHX=""
  1. S X=$E(PID,5,8)
  1. F I=1:1:4 S:$E(X,I)'="-" AMHX=AMHX_$E(X,I)
  1. S X=AMHX,X1=16 D DEC^XTBASE S AMHX=Y
  1. S AMHX=$$HTE^XLFDT(AMHX,1)
  1. S AMHV=AMHV_"__"_AMHX
  1. ;----------
  1. ; last 4 digits of SSN
  1. S AMHX=$E(PID,9,12)
  1. F I=1:1:4 D
  1. . S X=$E(AMHX,I)
  1. . I X<5 S X=X+5,$E(AMHX,I)=X I 1
  1. . E S X=X-5,$E(AMHX,I)=X
  1. . Q
  1. S:AMHX="9999" AMHX=" "
  1. S AMHV=AMHV_"__"_AMHX
  1. ;----------
  1. S AMHV=AMHV_"]"
  1. DECX ;
  1. Q AMHV
  1. ;
  1. DECRYPT ;
  1. S PID=$TR(PID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. S PID=$TR(PID,"8967320415","1234567890")
  1. Q