source: WorldVistAEHR/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSJPHNM.m@ 701

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

initial load of WorldVistAEHR

File size: 5.5 KB
Line 
1BPSJPHNM ;BHAM ISC/LJF - HL7 E-Pharm Phone Number Parser ;21-NOV-2003
2 ;;1.0;E CLAIMS MGMT ENGINE;**1**;JUN 2004
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6 ;
7EN(IX1,C,R) ;
8 ; Called with Person Index from VA(200
9 N N13,RETVAL,RETP,IX,IX2,UC,LC,PHT,SP,C3,PHD,PHDH,FLAG,PHI
10 ;
11 I '$G(IX1) Q ""
12 I $G(IX1) S N13=$G(^VA(200,+IX1,.13))
13 I $G(N13)="" Q ""
14 I $G(C)="" S C="^"
15 I $G(R)="" S R="~"
16 ;
17 ; Set up lowercase to UPPERCASE translation
18 S LC="abcdefghijklmnopqrstuvwxyz"
19 S UC="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
20 S SP=" ",C3=C_C_C
21 ;
22 S PHT(1)=C_"PRN"_C_"PH"_C3 ; home phone
23 S PHT(2)=C_"WPN"_C_"PH"_C3 ; work phone
24 S PHT(3)=C_"WPN"_C_"PH"_C3 ; 3rd phone
25 S PHT(4)=C_"WPN"_C_"PH"_C3 ; 4th phone
26 S PHT(5)=C_"WPN"_C_"PH"_C3 ; Commercial phone
27 S PHT(6)=C_"WPN"_C_"FX"_C3 ; Fax Number
28 S PHT(7)=C_"BPN"_C_"BP"_C3 ; Voice Pager Number
29 S PHT(8)=C_"BPN"_C_"BP"_C3 ; Digital Pager Number
30 S (PHI(9),PHI(9,1),PHI(9,2),PHI(9,3),PHI(9,4),PHI(9,5))=""
31 ;
32 K PHD M PHD=PHI S PHD=$G(^VA(200,IX1,.13)) I $TR(PHD,"^ ")="" Q ""
33 S PHD(10)=PHD
34 ; Trim leading and trailing spaces from each piece
35 F IX2=1:1:8 D
36 . I $TR($P(PHD,U,IX2),SP)="" S $P(PHD,U,IX2)="" Q
37 . S PHDH=$P(PHD,U,IX2)
38 . S $P(PHDH,$E($TR(PHDH,SP)))="" ; remove leading spaces
39 . S PHDH=$RE(PHDH),$P(PHDH,$E($TR(PHDH,SP)))="",PHDH=$RE(PHDH) ; remove trailing spaces
40 . ; remove duplicate work numbers
41 . I IX2>1,IX2<6 D Q
42 . . I $G(PHD(11,PHDH)) S $P(PHD,U,IX2)=""
43 . . E S PHD(11,PHDH)=IX2 S $P(PHD,U,IX2)=PHDH
44 . S $P(PHD,U,IX2)=PHDH
45 S PHD(10)=PHD
46 ;
47 ; Massage pagers into pieces 7&8
48 F IX2=1:1:6 S PHDH=$P(PHD,U,IX2),FLAG="" I PHDH]"" D
49 . I PHDH["BEEPER" D
50 . . S FLAG="1"_$P(PHDH,"BEEPER",2,99),PHDH=$P(PHDH,"BEEPER")
51 . I PHDH["BEEP" D
52 . . S FLAG="1"_$P(PHDH,"BEEP",2,99),PHDH=$P(PHDH,"BEEP")
53 . I PHDH["BP#" D
54 . . S FLAG="1"_$P(PHDH,"BP#",2,99),PHDH=$P(PHDH,"BP#")
55 . I PHDH["BP #" D
56 . . S FLAG="1"_$P(PHDH,"BP #",2,99),PHDH=$P(PHDH,"BP #")
57 . I PHDH["BP " D
58 . . S FLAG="1"_$P(PHDH,"BP ",2,99),PHDH=$P(PHDH,"BP ")
59 . I PHDH["BP" D
60 . . S FLAG="1"_$P(PHDH,"BP",2,99),PHDH=$P(PHDH,"BP")
61 . I FLAG D
62 . . S $P(PHD,U,IX2)=PHDH,$E(FLAG)=""
63 . . I $P(PHD,U,8)="" S $P(PHD,U,8)=FLAG Q
64 . . I $P(PHD,U,7)="" S $P(PHD,U,7)=FLAG Q
65 . . S $P(PHD,U,8)=$P(PHD,U,8)_" BP#"_FLAG
66 ;
67 F IX2=1:1:8 S PHD(IX2)=$P(PHD,U,IX2),PHD(IX2,1)="" I PHD(IX2)]"" D
68 . S PHD(IX2,1)=$$RESOLVEP(PHD(IX2))
69 . ;Init flag fields then load flags
70 . M PHD(IX2,9)=PHD(9)
71 ;
72 S RETVAL="",RETP=0
73 F IX2=1:1:8 D
74 . I '$L(PHD(IX2)) Q
75 . I '$L(PHD(IX2,1)) S $P(PHD(IX2,1),U,4)=PHD(IX2)
76 . S PHD(IX2,1)=PHT(IX2)_PHD(IX2,1)
77 . S RETP=RETP+1,$P(RETVAL,R,RETP)=PHD(IX2,1)
78 . Q
79 Q RETVAL
80 ;
81RESOLVEP(PH) ;
82 ;
83 N WPA,WPN,WPNH,STDN,WPT,IX,STDN,PREFIX
84 ;
85 S WPT=$TR(PH,LC,UC),PREFIX=0
86 S $P(WPN,SP,$L(WPT))=SP,WPA=WPN
87 ;
88 ; Separate numerics from text
89 F IX=1:1:$L(WPT) D
90 . I '$E(WPT,IX),$E(WPT,IX)'=0 S $E(WPA,IX)=$E(WPT,IX)
91 . E S $E(WPN,IX)=$E(PH,IX)
92 ; Quit if no numerics
93 I '$L($TR(WPN,SP)) Q ""
94 ;
95 S WPNH=WPN ; save a copy of the numeric data
96 ;
97 S $P(WPN,$E($TR(WPN,SP)))="" ; remove leading spaces
98 S WPN=$RE(WPN),$P(WPN,$E($TR(WPN,SP)))="",WPN=$RE(WPN) ; remove trailing spaces
99 ; Reduce multiple spaces to single spaces
100 F IX=$L(WPN):-1:1 I ($E(WPN,IX,IX+1)=(SP_SP)) S $E(WPN,IX)=""
101 ;
102 ; WPN contains only NUMBERS and SPACES at this point
103 ; check if it is preceded by a 1 as in "1 800 345 9933"
104 I $E(WPN,1,2)="1 " S $E(WPN,1,2)="",PREFIX=2
105 I 'PREFIX,$E(WPN)=1 S $E(WPN)="",PREFIX=1
106 ; check if it's a standard 10 digit number
107 S STDN=0
108 I $L($TR(WPN,SP))=10 S STDN=1 D
109 . I $L(WPN)=10 D I STDN=1 Q ; format: 1234567890
110 . . S WPN(1)=$E(WPN,1,3),WPN(2)=$E(WPN,4,6),WPN(3)=$E(WPN,7,10)
111 . . I PH[WPN(1),PH[WPN(2),PH[WPN(3)
112 . . E S STDN=0
113 . S STDN=1
114 . I $L(WPN,SP)=3 D I STDN Q ; format: 123 456 7890
115 . . S WPN(1)=$P(WPN,SP,1),WPN(2)=$P(WPN,SP,2),WPN(3)=$P(WPN,SP,3)
116 . . I $L(WPN(1))=3,PH[WPN(1),$L(WPN(2))=3,PH[WPN(2),$L(WPN(3))=4,PH[WPN(3)
117 . . E S STDN=0
118 . S STDN=1
119 . I $L(WPN,SP)=2 D I STDN=1 Q ; Still may be salvageable
120 . . S WPN(1)=$P(WPN,SP,1),WPN(2)=$P(WPN,SP,2)
121 . . ; is format "123 4567890"? area code & city/phone
122 . . I $L(WPN(1))=3 S WPN(3)=$E(WPN(2),4,7),$E(WPN(2),4,7)="" Q
123 . . ; is format "123456 7890"? area/city code & phone
124 . . I $L(WPN(1))=6 S WPN(3)=WPN(2),WPN(2)=$E(WPN(1),4,6),$E(WPN(1),4,6)="" Q
125 . . S STDN=0 ;unsalvageable as standard number
126 . S STDN=0 ;unsalvageable as standard number
127 ;
128 ; Quit if standard format
129 I STDN Q WPN(1)_WPN(2)_C_WPN(3)
130 ;
131 ;Not standard, need to do some work
132 ;
133 F IX=1:1:$L(WPN,SP) S WPN(IX)=$P(WPN,SP,IX)
134 S IX=$L(WPN,SP),WPN(0)=""
135 ;
136 ; add prefix back in if applicable
137 I PREFIX=1,$L(WPN(1))'=10 S WPN(1)="1"_WPN(1)
138 ;
139 ; 1 string of digits
140 I IX=1 D Q:$L(WPN(0)) WPN(0)
141 . I $L(WPN(1))<7 S WPN(0)=C_C_WPN(1) Q ;assume it's an extension
142 . I $L(WPN(1))=7 S WPN(0)=$E(WPN(1),1,3)_C_$E(WPN(1),4,7) Q ;city code & local number
143 ;
144 ; 2 strings of digits
145 I IX=2 D Q:$L(WPN(0)) WPN(0)
146 . ; could be city code & local number
147 . I $L(WPN(1))=3,$L(WPN(2))=4 S WPN(0)=WPN(1)_C_WPN(2) Q
148 . ; could be full number plus extension
149 . I $L(WPN(1))=10 S WPN(0)=$E(WPN(1),1,6)_C_$E(WPN(1),7,10)_C_WPN(2)
150 ;
151 ; 3 strings could include extension
152 I IX=3 D Q:$L(WPN(0)) WPN(0)
153 . ; "301 7933124 123"
154 . 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
155 . ; "793 3124 123"
156 . I $L(WPN(1))=3,$L(WPN(2))=4 S WPN(0)=WPN(1)_C_WPN(2)_C_WPN(3)
157 ;
158 ; 4 strings could include extension "301 344 2111 3424
159 I IX=4 D Q:$L(WPN(0)) WPN(0)
160 . 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)
161 ;
162 Q ""
Note: See TracBrowser for help on using the repository browser.