BPSJPHNM ;BHAM ISC/LJF - HL7 E-Pharm Phone Number Parser ;21-NOV-2003
;;1.0;E CLAIMS MGMT ENGINE;**1**;JUN 2004
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
;
EN(IX1,C,R) ;
; Called with Person Index from VA(200
N N13,RETVAL,RETP,IX,IX2,UC,LC,PHT,SP,C3,PHD,PHDH,FLAG,PHI
;
I '$G(IX1) Q ""
I $G(IX1) S N13=$G(^VA(200,+IX1,.13))
I $G(N13)="" Q ""
I $G(C)="" S C="^"
I $G(R)="" S R="~"
;
; Set up lowercase to UPPERCASE translation
S LC="abcdefghijklmnopqrstuvwxyz"
S UC="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
S SP=" ",C3=C_C_C
;
S PHT(1)=C_"PRN"_C_"PH"_C3 ; home phone
S PHT(2)=C_"WPN"_C_"PH"_C3 ; work phone
S PHT(3)=C_"WPN"_C_"PH"_C3 ; 3rd phone
S PHT(4)=C_"WPN"_C_"PH"_C3 ; 4th phone
S PHT(5)=C_"WPN"_C_"PH"_C3 ; Commercial phone
S PHT(6)=C_"WPN"_C_"FX"_C3 ; Fax Number
S PHT(7)=C_"BPN"_C_"BP"_C3 ; Voice Pager Number
S PHT(8)=C_"BPN"_C_"BP"_C3 ; Digital Pager Number
S (PHI(9),PHI(9,1),PHI(9,2),PHI(9,3),PHI(9,4),PHI(9,5))=""
;
K PHD M PHD=PHI S PHD=$G(^VA(200,IX1,.13)) I $TR(PHD,"^ ")="" Q ""
S PHD(10)=PHD
; Trim leading and trailing spaces from each piece
F IX2=1:1:8 D
. I $TR($P(PHD,U,IX2),SP)="" S $P(PHD,U,IX2)="" Q
. S PHDH=$P(PHD,U,IX2)
. S $P(PHDH,$E($TR(PHDH,SP)))="" ; remove leading spaces
. S PHDH=$RE(PHDH),$P(PHDH,$E($TR(PHDH,SP)))="",PHDH=$RE(PHDH) ; remove trailing spaces
. ; remove duplicate work numbers
. I IX2>1,IX2<6 D Q
. . I $G(PHD(11,PHDH)) S $P(PHD,U,IX2)=""
. . E S PHD(11,PHDH)=IX2 S $P(PHD,U,IX2)=PHDH
. S $P(PHD,U,IX2)=PHDH
S PHD(10)=PHD
;
; Massage pagers into pieces 7&8
F IX2=1:1:6 S PHDH=$P(PHD,U,IX2),FLAG="" I PHDH]"" D
. I PHDH["BEEPER" D
. . S FLAG="1"_$P(PHDH,"BEEPER",2,99),PHDH=$P(PHDH,"BEEPER")
. I PHDH["BEEP" D
. . S FLAG="1"_$P(PHDH,"BEEP",2,99),PHDH=$P(PHDH,"BEEP")
. I PHDH["BP#" D
. . S FLAG="1"_$P(PHDH,"BP#",2,99),PHDH=$P(PHDH,"BP#")
. I PHDH["BP #" D
. . S FLAG="1"_$P(PHDH,"BP #",2,99),PHDH=$P(PHDH,"BP #")
. I PHDH["BP " D
. . S FLAG="1"_$P(PHDH,"BP ",2,99),PHDH=$P(PHDH,"BP ")
. I PHDH["BP" D
. . S FLAG="1"_$P(PHDH,"BP",2,99),PHDH=$P(PHDH,"BP")
. I FLAG D
. . S $P(PHD,U,IX2)=PHDH,$E(FLAG)=""
. . I $P(PHD,U,8)="" S $P(PHD,U,8)=FLAG Q
. . I $P(PHD,U,7)="" S $P(PHD,U,7)=FLAG Q
. . S $P(PHD,U,8)=$P(PHD,U,8)_" BP#"_FLAG
;
F IX2=1:1:8 S PHD(IX2)=$P(PHD,U,IX2),PHD(IX2,1)="" I PHD(IX2)]"" D
. S PHD(IX2,1)=$$RESOLVEP(PHD(IX2))
. ;Init flag fields then load flags
. M PHD(IX2,9)=PHD(9)
;
S RETVAL="",RETP=0
F IX2=1:1:8 D
. I '$L(PHD(IX2)) Q
. I '$L(PHD(IX2,1)) S $P(PHD(IX2,1),U,4)=PHD(IX2)
. S PHD(IX2,1)=PHT(IX2)_PHD(IX2,1)
. S RETP=RETP+1,$P(RETVAL,R,RETP)=PHD(IX2,1)
. Q
Q RETVAL
;
RESOLVEP(PH) ;
;
N WPA,WPN,WPNH,STDN,WPT,IX,STDN,PREFIX
;
S WPT=$TR(PH,LC,UC),PREFIX=0
S $P(WPN,SP,$L(WPT))=SP,WPA=WPN
;
; Separate numerics from text
F IX=1:1:$L(WPT) D
. I '$E(WPT,IX),$E(WPT,IX)'=0 S $E(WPA,IX)=$E(WPT,IX)
. E S $E(WPN,IX)=$E(PH,IX)
; Quit if no numerics
I '$L($TR(WPN,SP)) Q ""
;
S WPNH=WPN ; save a copy of the numeric data
;
S $P(WPN,$E($TR(WPN,SP)))="" ; remove leading spaces
S WPN=$RE(WPN),$P(WPN,$E($TR(WPN,SP)))="",WPN=$RE(WPN) ; remove trailing spaces
; Reduce multiple spaces to single spaces
F IX=$L(WPN):-1:1 I ($E(WPN,IX,IX+1)=(SP_SP)) S $E(WPN,IX)=""
;
; WPN contains only NUMBERS and SPACES at this point
; check if it is preceded by a 1 as in "1 800 345 9933"
I $E(WPN,1,2)="1 " S $E(WPN,1,2)="",PREFIX=2
I 'PREFIX,$E(WPN)=1 S $E(WPN)="",PREFIX=1
; check if it's a standard 10 digit number
S STDN=0
I $L($TR(WPN,SP))=10 S STDN=1 D
. I $L(WPN)=10 D I STDN=1 Q ; format: 1234567890
. . S WPN(1)=$E(WPN,1,3),WPN(2)=$E(WPN,4,6),WPN(3)=$E(WPN,7,10)
. . I PH[WPN(1),PH[WPN(2),PH[WPN(3)
. . E S STDN=0
. S STDN=1
. I $L(WPN,SP)=3 D I STDN Q ; format: 123 456 7890
. . S WPN(1)=$P(WPN,SP,1),WPN(2)=$P(WPN,SP,2),WPN(3)=$P(WPN,SP,3)
. . I $L(WPN(1))=3,PH[WPN(1),$L(WPN(2))=3,PH[WPN(2),$L(WPN(3))=4,PH[WPN(3)
. . E S STDN=0
. S STDN=1
. I $L(WPN,SP)=2 D I STDN=1 Q ; Still may be salvageable
. . S WPN(1)=$P(WPN,SP,1),WPN(2)=$P(WPN,SP,2)
. . ; is format "123 4567890"? area code & city/phone
. . I $L(WPN(1))=3 S WPN(3)=$E(WPN(2),4,7),$E(WPN(2),4,7)="" Q
. . ; is format "123456 7890"? area/city code & phone
. . I $L(WPN(1))=6 S WPN(3)=WPN(2),WPN(2)=$E(WPN(1),4,6),$E(WPN(1),4,6)="" Q
. . S STDN=0 ;unsalvageable as standard number
. S STDN=0 ;unsalvageable as standard number
;
; Quit if standard format
I STDN Q WPN(1)_WPN(2)_C_WPN(3)
;
;Not standard, need to do some work
;
F IX=1:1:$L(WPN,SP) S WPN(IX)=$P(WPN,SP,IX)
S IX=$L(WPN,SP),WPN(0)=""
;
; add prefix back in if applicable
I PREFIX=1,$L(WPN(1))'=10 S WPN(1)="1"_WPN(1)
;
; 1 string of digits
I IX=1 D Q:$L(WPN(0)) WPN(0)
. I $L(WPN(1))<7 S WPN(0)=C_C_WPN(1) Q ;assume it's an extension
. I $L(WPN(1))=7 S WPN(0)=$E(WPN(1),1,3)_C_$E(WPN(1),4,7) Q ;city code & local number
;
; 2 strings of digits
I IX=2 D Q:$L(WPN(0)) WPN(0)
. ; could be city code & local number
. I $L(WPN(1))=3,$L(WPN(2))=4 S WPN(0)=WPN(1)_C_WPN(2) Q
. ; could be full number plus extension
. I $L(WPN(1))=10 S WPN(0)=$E(WPN(1),1,6)_C_$E(WPN(1),7,10)_C_WPN(2)
;
; 3 strings could include extension
I IX=3 D Q:$L(WPN(0)) WPN(0)
. ; "301 7933124 123"
. I $L(WPN(1))=3,$L(WPN(2))=7 S WPN(0)=WPN(1)_$E(WPN(2),1,3)_C_$E(WPN(2),4,7)_C_WPN(3) Q
. ; "793 3124 123"
. I $L(WPN(1))=3,$L(WPN(2))=4 S WPN(0)=WPN(1)_C_WPN(2)_C_WPN(3)
;
; 4 strings could include extension "301 344 2111 3424
I IX=4 D Q:$L(WPN(0)) WPN(0)
. I $L(WPN(1))=3,$L(WPN(2))=3,$L(WPN(3))=4 S WPN(0)=WPN(1)_WPN(2)_C_WPN(3)_C_WPN(4)
;
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSJPHNM 5763 printed Apr 09, 2024@20:58:46 Page 2
BPSJPHNM ;BHAM ISC/LJF - HL7 E-Pharm Phone Number Parser ;21-NOV-2003
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1**;JUN 2004
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EN(IX1,C,R) ;
+1 ; Called with Person Index from VA(200
+2 NEW N13,RETVAL,RETP,IX,IX2,UC,LC,PHT,SP,C3,PHD,PHDH,FLAG,PHI
+3 ;
+4 IF '$GET(IX1)
QUIT ""
+5 IF $GET(IX1)
SET N13=$GET(^VA(200,+IX1,.13))
+6 IF $GET(N13)=""
QUIT ""
+7 IF $GET(C)=""
SET C="^"
+8 IF $GET(R)=""
SET R="~"
+9 ;
+10 ; Set up lowercase to UPPERCASE translation
+11 SET LC="abcdefghijklmnopqrstuvwxyz"
+12 SET UC="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+13 SET SP=" "
SET C3=C_C_C
+14 ;
+15 ; home phone
SET PHT(1)=C_"PRN"_C_"PH"_C3
+16 ; work phone
SET PHT(2)=C_"WPN"_C_"PH"_C3
+17 ; 3rd phone
SET PHT(3)=C_"WPN"_C_"PH"_C3
+18 ; 4th phone
SET PHT(4)=C_"WPN"_C_"PH"_C3
+19 ; Commercial phone
SET PHT(5)=C_"WPN"_C_"PH"_C3
+20 ; Fax Number
SET PHT(6)=C_"WPN"_C_"FX"_C3
+21 ; Voice Pager Number
SET PHT(7)=C_"BPN"_C_"BP"_C3
+22 ; Digital Pager Number
SET PHT(8)=C_"BPN"_C_"BP"_C3
+23 SET (PHI(9),PHI(9,1),PHI(9,2),PHI(9,3),PHI(9,4),PHI(9,5))=""
+24 ;
+25 KILL PHD
MERGE PHD=PHI
SET PHD=$GET(^VA(200,IX1,.13))
IF $TRANSLATE(PHD,"^ ")=""
QUIT ""
+26 SET PHD(10)=PHD
+27 ; Trim leading and trailing spaces from each piece
+28 FOR IX2=1:1:8
Begin DoDot:1
+29 IF $TRANSLATE($PIECE(PHD,U,IX2),SP)=""
SET $PIECE(PHD,U,IX2)=""
QUIT
+30 SET PHDH=$PIECE(PHD,U,IX2)
+31 ; remove leading spaces
SET $PIECE(PHDH,$EXTRACT($TRANSLATE(PHDH,SP)))=""
+32 ; remove trailing spaces
SET PHDH=$REVERSE(PHDH)
SET $PIECE(PHDH,$EXTRACT($TRANSLATE(PHDH,SP)))=""
SET PHDH=$REVERSE(PHDH)
+33 ; remove duplicate work numbers
+34 IF IX2>1
IF IX2<6
Begin DoDot:2
+35 IF $GET(PHD(11,PHDH))
SET $PIECE(PHD,U,IX2)=""
+36 IF '$TEST
SET PHD(11,PHDH)=IX2
SET $PIECE(PHD,U,IX2)=PHDH
End DoDot:2
QUIT
+37 SET $PIECE(PHD,U,IX2)=PHDH
End DoDot:1
+38 SET PHD(10)=PHD
+39 ;
+40 ; Massage pagers into pieces 7&8
+41 FOR IX2=1:1:6
SET PHDH=$PIECE(PHD,U,IX2)
SET FLAG=""
IF PHDH]""
Begin DoDot:1
+42 IF PHDH["BEEPER"
Begin DoDot:2
+43 SET FLAG="1"_$PIECE(PHDH,"BEEPER",2,99)
SET PHDH=$PIECE(PHDH,"BEEPER")
End DoDot:2
+44 IF PHDH["BEEP"
Begin DoDot:2
+45 SET FLAG="1"_$PIECE(PHDH,"BEEP",2,99)
SET PHDH=$PIECE(PHDH,"BEEP")
End DoDot:2
+46 IF PHDH["BP#"
Begin DoDot:2
+47 SET FLAG="1"_$PIECE(PHDH,"BP#",2,99)
SET PHDH=$PIECE(PHDH,"BP#")
End DoDot:2
+48 IF PHDH["BP #"
Begin DoDot:2
+49 SET FLAG="1"_$PIECE(PHDH,"BP #",2,99)
SET PHDH=$PIECE(PHDH,"BP #")
End DoDot:2
+50 IF PHDH["BP "
Begin DoDot:2
+51 SET FLAG="1"_$PIECE(PHDH,"BP ",2,99)
SET PHDH=$PIECE(PHDH,"BP ")
End DoDot:2
+52 IF PHDH["BP"
Begin DoDot:2
+53 SET FLAG="1"_$PIECE(PHDH,"BP",2,99)
SET PHDH=$PIECE(PHDH,"BP")
End DoDot:2
+54 IF FLAG
Begin DoDot:2
+55 SET $PIECE(PHD,U,IX2)=PHDH
SET $EXTRACT(FLAG)=""
+56 IF $PIECE(PHD,U,8)=""
SET $PIECE(PHD,U,8)=FLAG
QUIT
+57 IF $PIECE(PHD,U,7)=""
SET $PIECE(PHD,U,7)=FLAG
QUIT
+58 SET $PIECE(PHD,U,8)=$PIECE(PHD,U,8)_" BP#"_FLAG
End DoDot:2
End DoDot:1
+59 ;
+60 FOR IX2=1:1:8
SET PHD(IX2)=$PIECE(PHD,U,IX2)
SET PHD(IX2,1)=""
IF PHD(IX2)]""
Begin DoDot:1
+61 SET PHD(IX2,1)=$$RESOLVEP(PHD(IX2))
+62 ;Init flag fields then load flags
+63 MERGE PHD(IX2,9)=PHD(9)
End DoDot:1
+64 ;
+65 SET RETVAL=""
SET RETP=0
+66 FOR IX2=1:1:8
Begin DoDot:1
+67 IF '$LENGTH(PHD(IX2))
QUIT
+68 IF '$LENGTH(PHD(IX2,1))
SET $PIECE(PHD(IX2,1),U,4)=PHD(IX2)
+69 SET PHD(IX2,1)=PHT(IX2)_PHD(IX2,1)
+70 SET RETP=RETP+1
SET $PIECE(RETVAL,R,RETP)=PHD(IX2,1)
+71 QUIT
End DoDot:1
+72 QUIT RETVAL
+73 ;
RESOLVEP(PH) ;
+1 ;
+2 NEW WPA,WPN,WPNH,STDN,WPT,IX,STDN,PREFIX
+3 ;
+4 SET WPT=$TRANSLATE(PH,LC,UC)
SET PREFIX=0
+5 SET $PIECE(WPN,SP,$LENGTH(WPT))=SP
SET WPA=WPN
+6 ;
+7 ; Separate numerics from text
+8 FOR IX=1:1:$LENGTH(WPT)
Begin DoDot:1
+9 IF '$EXTRACT(WPT,IX)
IF $EXTRACT(WPT,IX)'=0
SET $EXTRACT(WPA,IX)=$EXTRACT(WPT,IX)
+10 IF '$TEST
SET $EXTRACT(WPN,IX)=$EXTRACT(PH,IX)
End DoDot:1
+11 ; Quit if no numerics
+12 IF '$LENGTH($TRANSLATE(WPN,SP))
QUIT ""
+13 ;
+14 ; save a copy of the numeric data
SET WPNH=WPN
+15 ;
+16 ; remove leading spaces
SET $PIECE(WPN,$EXTRACT($TRANSLATE(WPN,SP)))=""
+17 ; remove trailing spaces
SET WPN=$REVERSE(WPN)
SET $PIECE(WPN,$EXTRACT($TRANSLATE(WPN,SP)))=""
SET WPN=$REVERSE(WPN)
+18 ; Reduce multiple spaces to single spaces
+19 FOR IX=$LENGTH(WPN):-1:1
IF ($EXTRACT(WPN,IX,IX+1)=(SP_SP))
SET $EXTRACT(WPN,IX)=""
+20 ;
+21 ; WPN contains only NUMBERS and SPACES at this point
+22 ; check if it is preceded by a 1 as in "1 800 345 9933"
+23 IF $EXTRACT(WPN,1,2)="1 "
SET $EXTRACT(WPN,1,2)=""
SET PREFIX=2
+24 IF 'PREFIX
IF $EXTRACT(WPN)=1
SET $EXTRACT(WPN)=""
SET PREFIX=1
+25 ; check if it's a standard 10 digit number
+26 SET STDN=0
+27 IF $LENGTH($TRANSLATE(WPN,SP))=10
SET STDN=1
Begin DoDot:1
+28 ; format: 1234567890
IF $LENGTH(WPN)=10
Begin DoDot:2
+29 SET WPN(1)=$EXTRACT(WPN,1,3)
SET WPN(2)=$EXTRACT(WPN,4,6)
SET WPN(3)=$EXTRACT(WPN,7,10)
+30 IF PH[WPN(1)
IF PH[WPN(2)
IF PH[WPN(3)
+31 IF '$TEST
SET STDN=0
End DoDot:2
IF STDN=1
QUIT
+32 SET STDN=1
+33 ; format: 123 456 7890
IF $LENGTH(WPN,SP)=3
Begin DoDot:2
+34 SET WPN(1)=$PIECE(WPN,SP,1)
SET WPN(2)=$PIECE(WPN,SP,2)
SET WPN(3)=$PIECE(WPN,SP,3)
+35 IF $LENGTH(WPN(1))=3
IF PH[WPN(1)
IF $LENGTH(WPN(2))=3
IF PH[WPN(2)
IF $LENGTH(WPN(3))=4
IF PH[WPN(3)
+36 IF '$TEST
SET STDN=0
End DoDot:2
IF STDN
QUIT
+37 SET STDN=1
+38 ; Still may be salvageable
IF $LENGTH(WPN,SP)=2
Begin DoDot:2
+39 SET WPN(1)=$PIECE(WPN,SP,1)
SET WPN(2)=$PIECE(WPN,SP,2)
+40 ; is format "123 4567890"? area code & city/phone
+41 IF $LENGTH(WPN(1))=3
SET WPN(3)=$EXTRACT(WPN(2),4,7)
SET $EXTRACT(WPN(2),4,7)=""
QUIT
+42 ; is format "123456 7890"? area/city code & phone
+43 IF $LENGTH(WPN(1))=6
SET WPN(3)=WPN(2)
SET WPN(2)=$EXTRACT(WPN(1),4,6)
SET $EXTRACT(WPN(1),4,6)=""
QUIT
+44 ;unsalvageable as standard number
SET STDN=0
End DoDot:2
IF STDN=1
QUIT
+45 ;unsalvageable as standard number
SET STDN=0
End DoDot:1
+46 ;
+47 ; Quit if standard format
+48 IF STDN
QUIT WPN(1)_WPN(2)_C_WPN(3)
+49 ;
+50 ;Not standard, need to do some work
+51 ;
+52 FOR IX=1:1:$LENGTH(WPN,SP)
SET WPN(IX)=$PIECE(WPN,SP,IX)
+53 SET IX=$LENGTH(WPN,SP)
SET WPN(0)=""
+54 ;
+55 ; add prefix back in if applicable
+56 IF PREFIX=1
IF $LENGTH(WPN(1))'=10
SET WPN(1)="1"_WPN(1)
+57 ;
+58 ; 1 string of digits
+59 IF IX=1
Begin DoDot:1
+60 ;assume it's an extension
IF $LENGTH(WPN(1))<7
SET WPN(0)=C_C_WPN(1)
QUIT
+61 ;city code & local number
IF $LENGTH(WPN(1))=7
SET WPN(0)=$EXTRACT(WPN(1),1,3)_C_$EXTRACT(WPN(1),4,7)
QUIT
End DoDot:1
if $LENGTH(WPN(0))
QUIT WPN(0)
+62 ;
+63 ; 2 strings of digits
+64 IF IX=2
Begin DoDot:1
+65 ; could be city code & local number
+66 IF $LENGTH(WPN(1))=3
IF $LENGTH(WPN(2))=4
SET WPN(0)=WPN(1)_C_WPN(2)
QUIT
+67 ; could be full number plus extension
+68 IF $LENGTH(WPN(1))=10
SET WPN(0)=$EXTRACT(WPN(1),1,6)_C_$EXTRACT(WPN(1),7,10)_C_WPN(2)
End DoDot:1
if $LENGTH(WPN(0))
QUIT WPN(0)
+69 ;
+70 ; 3 strings could include extension
+71 IF IX=3
Begin DoDot:1
+72 ; "301 7933124 123"
+73 IF $LENGTH(WPN(1))=3
IF $LENGTH(WPN(2))=7
SET WPN(0)=WPN(1)_$EXTRACT(WPN(2),1,3)_C_$EXTRACT(WPN(2),4,7)_C_WPN(3)
QUIT
+74 ; "793 3124 123"
+75 IF $LENGTH(WPN(1))=3
IF $LENGTH(WPN(2))=4
SET WPN(0)=WPN(1)_C_WPN(2)_C_WPN(3)
End DoDot:1
if $LENGTH(WPN(0))
QUIT WPN(0)
+76 ;
+77 ; 4 strings could include extension "301 344 2111 3424
+78 IF IX=4
Begin DoDot:1
+79 IF $LENGTH(WPN(1))=3
IF $LENGTH(WPN(2))=3
IF $LENGTH(WPN(3))=4
SET WPN(0)=WPN(1)_WPN(2)_C_WPN(3)_C_WPN(4)
End DoDot:1
if $LENGTH(WPN(0))
QUIT WPN(0)
+80 ;
+81 QUIT ""
