source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XIPUTIL.m@ 1578

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

initial load of WorldVistAEHR
File size: 6.9 KB
RevLine 
[613]1XIPUTIL ;ALB/BRM,OIFO/SO - POSTAL AND COUNTY CODE APIS ;2:16 PM 10 Jul 2003
2 ;;8.0;KERNEL;**246,292**;Jul 10, 1995
3 ;
4 ; this routine holds APIs used to extract data from the
5 ; County Code (#5.13) and Postal Code (#5.12) files.
6 ;
7 Q
8 ;
9POSTAL(PCODE,XIP) ; return all data for the Prefered City for a postal code
10 ;
11 ; INPUT
12 ; PCODE - Postal Code for which to return the data
13 ;
14 ; OUTPUT
15 ; XIP("POSTAL CODE") - the value used to lookup postal data
16 ; XIP("CITY") - the city that the USPS assigned to this PCODE
17 ; XIP("COUNTY") - The county associated with this PCODE
18 ; XIP("COUNTY POINTER") - pointer to the county in file #5.13
19 ; XIP("STATE") - The state associated with this PCODE
20 ; XIP("STATE POINTER") - pointer to the state in file #5
21 ; XIP("CITY KEY") - USPS's assigned city key
22 ; XIP("PREFERRED CITY KEY") - USPS's Prefered (DEFAULT) city key
23 ; XIP("CITY ABBREVIATION") - USPS's assigned abbreviation
24 ; XIP("UNIQUE KEY") - a unique look-up value
25 ; XIP("FIPS CODE") - 5 digit FIPS code associated with the county
26 ; XIP("ERROR") - returns errors encountered during look-up
27 ;
28 I $G(PCODE)']"" S XIP("ERROR")="Missing Input Parameter" Q
29 N X,ERR512,XIP512,XIPTMP,X,Y,DA,D,DIQ,DIC,IENS,XIPERR,LPCODE
30 ; initialize the XIP data array
31 D INITXIP(.XIP)
32 ; initialize additional XIP subscripts
33 F X="CITY","COUNTY POINTER","POSTAL CODE","CITY KEY","PREFERRED CITY KEY","CITY ABBREVIATION","UNIQUE KEY" S XIP(X)=""
34 K XIP("INACTIVE DATE") ;Inactive dates are screen out
35 ; if input parameter (PCODE) is less than 5 characters, quit w/error
36 I $L(PCODE)<5 S XIP("ERROR")="PCODE entered was less than 5 characters." Q
37 S (LPCODE,XIP("POSTAL CODE"))=$E(PCODE,1,5)
38 S XIP512=0
39 D
40 . N DIERR,XIPERR,FIELDS,I,D512,S512
41 . S FIELDS="@;5;6"
42 . S S512="I $P(^(0),U,5)=""""" ; Screen out INACTIVE Zip Codes
43 . D LIST^DIC(5.12,"",FIELDS,"P","","",LPCODE,"B",S512,"","D512","XIPERR")
44 . Q:$D(DIERR)
45 . S I=0
46 . F S I=$O(D512("DILIST",I)) Q:'I D
47 .. I $P(D512("DILIST",I,0),"^",2)=$P(D512("DILIST",I,0),"^",3) S XIP512=$P(D512("DILIST",I,0),"^",1)
48 I 'XIP512 S XIP("ERROR")="Postal Code cannot be found" Q
49 N X
50 S X=^XIP(5.12,XIP512,0)
51 S XIP("CITY")=$P(X,"^",2)
52 S XIP("COUNTY POINTER")=$P(X,"^",3)
53 S XIP("STATE POINTER")=$P(X,"^",4)
54 S XIP("INACTIVE DATE")=$P(X,"^",5)
55 S XIP("CITY KEY")=$P(X,"^",6)
56 S XIP("PREFERRED CITY KEY")=$P(X,"^",7)
57 S XIP("CITY ABBREVIATION")=$P(X,"^",8)
58 S XIP("UNIQUE KEY")=$P(X,"^",9)
59 S XIP("STATE")=$P($G(^DIC(5,+XIP("STATE POINTER"),0)),"^")
60 S XIP("COUNTY")=$P($G(^XIP(5.13,+XIP("COUNTY POINTER"),0)),"^",2)
61 S XIP("FIPS CODE")=$P($G(^XIP(5.13,+XIP("COUNTY POINTER"),0)),"^")
62 Q
63 ;
64INITXIP(ARRY) ;initialize the county code array
65 F X="COUNTY","STATE","STATE POINTER","INACTIVE DATE","FIPS CODE" S ARRY(X)=""
66 Q
67 ;
68FIPS(PCODE) ;API to return the FIPS code associated with the postal code
69 ;
70 ;INPUT:
71 ; PCODE - Postal code
72 ;OUTPUT:
73 ; 5 digit FIPS code associated with the entered postal code
74 ; or "0^error message" if a processing error occurs
75 ;
76 Q:PCODE']"" "0^Missing Input Parameter"
77 Q:$L(PCODE)<5 "0^Input Parameter is less than 5 characters"
78 ;
79 N IEN512,IEN513,FIPS
80 I $L(PCODE)>5 S PCODE=$E(PCODE,1,5)
81 S IEN512=0
82 D
83 . N DIERR,XIPERR,FIELDS,XIPTMP,I
84 . S FIELDS="@;5;6"
85 . D LIST^DIC(5.12,"",FIELDS,"P","","",PCODE,"","","","XIPTMP","XIPERR")
86 . Q:$D(DIERR)
87 . S I=0
88 . F S I=$O(XIPTMP("DILIST",I)) Q:'I D
89 .. I $P(XIPTMP("DILIST",I,0),"^",2)=$P(XIPTMP("DILIST",I,0),"^",3) S IEN512=$P(XIPTMP("DILIST",I,0),"^",1)
90 Q:'IEN512 "0^Postal Code not found"
91 S IEN513=$P($G(^XIP(5.12,IEN512,0)),"^",3)
92 Q:'IEN513 "0^County cannot be determined"
93 S FIPS=$$GET1^DIQ(5.13,IEN513_",",.01)
94 Q:FIPS FIPS
95 Q "0^FIPS Code cannot be determined"
96 ;
97CCODE(FIPS,XIPC) ; return all data related to a FIPS county code
98 ;
99 ; INPUT
100 ; FIPS - 5 digit FIPS County Code for which to return the data
101 ;
102 ; OUTPUT
103 ; XIPC("FIPS CODE") - 5 digit FIPS county code
104 ; XIPC("COUNTY") - The county associated with this FIPS code
105 ; XIPC("STATE") - The state associated with this FIPS code
106 ; XIPC("STATE POINTER") - pointer to the state in file #5
107 ; XIPC("INACTIVE DATE") - date this FIPS code was inactivated
108 ; XIPC("LATITUDE") - The estimated Latitude of the county
109 ; XIPC("LONGITUDE") - The estimated Longitude of the county
110 ; XIPC("ERROR") - returns errors encountered during look-up
111 ;
112 I $G(FIPS)']"" S XIPC("ERROR")="Missing Input Parameter" Q
113 ;
114 N X,XIPCTMP,XIP513,ERR513,IENS
115 ; initialize the XIPC data array
116 D INITXIP(.XIPC)
117 S XIPC("LATITUDE")="",XIPC("LONGITUDE")=""
118 S XIPC("FIPS CODE")=FIPS
119 ; if input parameter (FIPS) is less than 5 characters, quit w/error
120 I $G(FIPS)'?5N S XIPC("ERROR")="FIPS Code input parameter is not valid." Q
121 ;
122 S XIP513=0
123 D
124 . N DIERR,XIPERR
125 . S XIP513=$$FIND1^DIC(5.13,,"BOX",FIPS,"","","XIPERR")
126 I 'XIP513 D Q:'XIP513
127 .S XIP513=$O(^XIP(5.13,"B",FIPS,""))
128 .I XIP513 S XIPC("ERROR")="Multiple entries exist for FIPS code" Q
129 .S XIPC("ERROR")="Entered FIPS Code could not be found"
130 D
131 . N DIERR
132 . D GETS^DIQ(5.13,XIP513_",","**","IE","XIPCTMP","ERR513")
133 I $D(ERR513) S XIPC("ERROR")="Error occurred while retrieving County Code data" Q
134 ;put data into array
135 S XIP513=XIP513_","
136 S XIPC("COUNTY")=$G(XIPCTMP(5.13,XIP513,1,"E"))
137 S XIPC("STATE")=$G(XIPCTMP(5.13,XIP513,2,"E"))
138 S XIPC("STATE POINTER")=$G(XIPCTMP(5.13,XIP513,2,"I"))
139 S XIPC("INACTIVE DATE")=$G(XIPCTMP(5.13,XIP513,3,"I"))
140 S XIPC("LATITUDE")=$G(XIPCTMP(5.13,XIP513,4,"E"))
141 S XIPC("LONGITUDE")=$G(XIPCTMP(5.13,XIP513,5,"E"))
142 Q
143FIPSCHK(FIPS) ; does this FIPS code exist?
144 Q:$G(FIPS)']"" 0
145 Q:$L(FIPS)<5 0
146 Q +$O(^XIP(5.13,"B",FIPS,""))
147 ;
148POSTALB(PCODE,XIP) ; return all data related to a postal code
149 ;
150 ; INPUT
151 ; PCODE - Postal Code for which to return the data
152 ;
153 ; OUTPUT
154 ; XIP(n) - the number of primary subscripts
155 ; XIP(n,"POSTAL CODE") - the value used to lookup postal data
156 ; XIP(n,"CITY") - the city that the USPS assigned to this PCODE
157 ; XIP(n,"COUNTY") - The county associated with this PCODE
158 ; XIP(n,"COUNTY POINTER") - pointer to the county in file #5.13
159 ; XIP(n,"STATE") - The state associated with this PCODE
160 ; XIP(n,"STATE POINTER") - pointer to the state in file #5
161 ; XIP(n,"INACTIVE DATE") - date on which this PCODE was inactivated
162 ; XIP(n"CITY KEY") - USPS's assigned city key
163 ; XIP(n,"PREFERRED CITY KEY") - USPS's Preferred (DEFAULT) city key
164 ; XIP(n,"CITY ABBREVIATION") - USPS's assigned abbreviation
165 ; XIP(n,"UNIQUE KEY") - a unique look-up value
166 ; XIP(n,"FIPS CODE") - 5 digit FIPS code associated with the county
167 ; XIP("ERROR") - returns errors encountered during look-up
168 ;
169 S XIP=0
170 I $G(PCODE)']"" S XIP("ERROR")="Missing Input Parameter" Q
171 N X,ERR512,XIP512,XIPTMP,X,Y,DA,D,DIQ,DIC,IENS,XIPERR,LPCODE
172 ; if input parameter (PCODE) is less than 5 characters, quit w/error
173 I $L(PCODE)<5 S XIP("ERROR")="PCODE entered was less than 5 characters." Q
174 ;
175 S LPCODE=$E(PCODE,1,5)
176 D PBC^XIPUTIL1 ; Continue processing
177 Q
Note: See TracBrowser for help on using the repository browser.