- 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