XIPUTIL ;ALB/BRM,OIFO/SO - POSTAL AND COUNTY CODE APIS ;2:16 PM 10 Jul 2003
;;8.0;KERNEL;**246,292**;Jul 10, 1995
;
; this routine holds APIs used to extract data from the
; County Code (#5.13) and Postal Code (#5.12) files.
;
Q
;
POSTAL(PCODE,XIP) ; return all data for the Prefered City for a postal code
;
; INPUT
; PCODE - Postal Code for which to return the data
;
; OUTPUT
; XIP("POSTAL CODE") - the value used to lookup postal data
; XIP("CITY") - the city that the USPS assigned to this PCODE
; XIP("COUNTY") - The county associated with this PCODE
; XIP("COUNTY POINTER") - pointer to the county in file #5.13
; XIP("STATE") - The state associated with this PCODE
; XIP("STATE POINTER") - pointer to the state in file #5
; XIP("CITY KEY") - USPS's assigned city key
; XIP("PREFERRED CITY KEY") - USPS's Prefered (DEFAULT) city key
; XIP("CITY ABBREVIATION") - USPS's assigned abbreviation
; XIP("UNIQUE KEY") - a unique look-up value
; XIP("FIPS CODE") - 5 digit FIPS code associated with the county
; XIP("ERROR") - returns errors encountered during look-up
;
I $G(PCODE)']"" S XIP("ERROR")="Missing Input Parameter" Q
N X,ERR512,XIP512,XIPTMP,X,Y,DA,D,DIQ,DIC,IENS,XIPERR,LPCODE
; initialize the XIP data array
D INITXIP(.XIP)
; initialize additional XIP subscripts
F X="CITY","COUNTY POINTER","POSTAL CODE","CITY KEY","PREFERRED CITY KEY","CITY ABBREVIATION","UNIQUE KEY" S XIP(X)=""
K XIP("INACTIVE DATE") ;Inactive dates are screen out
; if input parameter (PCODE) is less than 5 characters, quit w/error
I $L(PCODE)<5 S XIP("ERROR")="PCODE entered was less than 5 characters." Q
S (LPCODE,XIP("POSTAL CODE"))=$E(PCODE,1,5)
S XIP512=0
D
. N DIERR,XIPERR,FIELDS,I,D512,S512
. S FIELDS="@;5;6"
. S S512="I $P(^(0),U,5)=""""" ; Screen out INACTIVE Zip Codes
. D LIST^DIC(5.12,"",FIELDS,"P","","",LPCODE,"B",S512,"","D512","XIPERR")
. Q:$D(DIERR)
. S I=0
. F S I=$O(D512("DILIST",I)) Q:'I D
.. I $P(D512("DILIST",I,0),"^",2)=$P(D512("DILIST",I,0),"^",3) S XIP512=$P(D512("DILIST",I,0),"^",1)
I 'XIP512 S XIP("ERROR")="Postal Code cannot be found" Q
N X
S X=^XIP(5.12,XIP512,0)
S XIP("CITY")=$P(X,"^",2)
S XIP("COUNTY POINTER")=$P(X,"^",3)
S XIP("STATE POINTER")=$P(X,"^",4)
S XIP("INACTIVE DATE")=$P(X,"^",5)
S XIP("CITY KEY")=$P(X,"^",6)
S XIP("PREFERRED CITY KEY")=$P(X,"^",7)
S XIP("CITY ABBREVIATION")=$P(X,"^",8)
S XIP("UNIQUE KEY")=$P(X,"^",9)
S XIP("STATE")=$P($G(^DIC(5,+XIP("STATE POINTER"),0)),"^")
S XIP("COUNTY")=$P($G(^XIP(5.13,+XIP("COUNTY POINTER"),0)),"^",2)
S XIP("FIPS CODE")=$P($G(^XIP(5.13,+XIP("COUNTY POINTER"),0)),"^")
Q
;
INITXIP(ARRY) ;initialize the county code array
F X="COUNTY","STATE","STATE POINTER","INACTIVE DATE","FIPS CODE" S ARRY(X)=""
Q
;
FIPS(PCODE) ;API to return the FIPS code associated with the postal code
;
;INPUT:
; PCODE - Postal code
;OUTPUT:
; 5 digit FIPS code associated with the entered postal code
; or "0^error message" if a processing error occurs
;
Q:PCODE']"" "0^Missing Input Parameter"
Q:$L(PCODE)<5 "0^Input Parameter is less than 5 characters"
;
N IEN512,IEN513,FIPS
I $L(PCODE)>5 S PCODE=$E(PCODE,1,5)
S IEN512=0
D
. N DIERR,XIPERR,FIELDS,XIPTMP,I
. S FIELDS="@;5;6"
. D LIST^DIC(5.12,"",FIELDS,"P","","",PCODE,"","","","XIPTMP","XIPERR")
. Q:$D(DIERR)
. S I=0
. F S I=$O(XIPTMP("DILIST",I)) Q:'I D
.. I $P(XIPTMP("DILIST",I,0),"^",2)=$P(XIPTMP("DILIST",I,0),"^",3) S IEN512=$P(XIPTMP("DILIST",I,0),"^",1)
Q:'IEN512 "0^Postal Code not found"
S IEN513=$P($G(^XIP(5.12,IEN512,0)),"^",3)
Q:'IEN513 "0^County cannot be determined"
S FIPS=$$GET1^DIQ(5.13,IEN513_",",.01)
Q:FIPS FIPS
Q "0^FIPS Code cannot be determined"
;
CCODE(FIPS,XIPC) ; return all data related to a FIPS county code
;
; INPUT
; FIPS - 5 digit FIPS County Code for which to return the data
;
; OUTPUT
; XIPC("FIPS CODE") - 5 digit FIPS county code
; XIPC("COUNTY") - The county associated with this FIPS code
; XIPC("STATE") - The state associated with this FIPS code
; XIPC("STATE POINTER") - pointer to the state in file #5
; XIPC("INACTIVE DATE") - date this FIPS code was inactivated
; XIPC("LATITUDE") - The estimated Latitude of the county
; XIPC("LONGITUDE") - The estimated Longitude of the county
; XIPC("ERROR") - returns errors encountered during look-up
;
I $G(FIPS)']"" S XIPC("ERROR")="Missing Input Parameter" Q
;
N X,XIPCTMP,XIP513,ERR513,IENS
; initialize the XIPC data array
D INITXIP(.XIPC)
S XIPC("LATITUDE")="",XIPC("LONGITUDE")=""
S XIPC("FIPS CODE")=FIPS
; if input parameter (FIPS) is less than 5 characters, quit w/error
I $G(FIPS)'?5N S XIPC("ERROR")="FIPS Code input parameter is not valid." Q
;
S XIP513=0
D
. N DIERR,XIPERR
. S XIP513=$$FIND1^DIC(5.13,,"BOX",FIPS,"","","XIPERR")
I 'XIP513 D Q:'XIP513
.S XIP513=$O(^XIP(5.13,"B",FIPS,""))
.I XIP513 S XIPC("ERROR")="Multiple entries exist for FIPS code" Q
.S XIPC("ERROR")="Entered FIPS Code could not be found"
D
. N DIERR
. D GETS^DIQ(5.13,XIP513_",","**","IE","XIPCTMP","ERR513")
I $D(ERR513) S XIPC("ERROR")="Error occurred while retrieving County Code data" Q
;put data into array
S XIP513=XIP513_","
S XIPC("COUNTY")=$G(XIPCTMP(5.13,XIP513,1,"E"))
S XIPC("STATE")=$G(XIPCTMP(5.13,XIP513,2,"E"))
S XIPC("STATE POINTER")=$G(XIPCTMP(5.13,XIP513,2,"I"))
S XIPC("INACTIVE DATE")=$G(XIPCTMP(5.13,XIP513,3,"I"))
S XIPC("LATITUDE")=$G(XIPCTMP(5.13,XIP513,4,"E"))
S XIPC("LONGITUDE")=$G(XIPCTMP(5.13,XIP513,5,"E"))
Q
FIPSCHK(FIPS) ; does this FIPS code exist?
Q:$G(FIPS)']"" 0
Q:$L(FIPS)<5 0
Q +$O(^XIP(5.13,"B",FIPS,""))
;
POSTALB(PCODE,XIP) ; return all data related to a postal code
;
; INPUT
; PCODE - Postal Code for which to return the data
;
; OUTPUT
; XIP(n) - the number of primary subscripts
; XIP(n,"POSTAL CODE") - the value used to lookup postal data
; XIP(n,"CITY") - the city that the USPS assigned to this PCODE
; XIP(n,"COUNTY") - The county associated with this PCODE
; XIP(n,"COUNTY POINTER") - pointer to the county in file #5.13
; XIP(n,"STATE") - The state associated with this PCODE
; XIP(n,"STATE POINTER") - pointer to the state in file #5
; XIP(n,"INACTIVE DATE") - date on which this PCODE was inactivated
; XIP(n"CITY KEY") - USPS's assigned city key
; XIP(n,"PREFERRED CITY KEY") - USPS's Preferred (DEFAULT) city key
; XIP(n,"CITY ABBREVIATION") - USPS's assigned abbreviation
; XIP(n,"UNIQUE KEY") - a unique look-up value
; XIP(n,"FIPS CODE") - 5 digit FIPS code associated with the county
; XIP("ERROR") - returns errors encountered during look-up
;
S XIP=0
I $G(PCODE)']"" S XIP("ERROR")="Missing Input Parameter" Q
N X,ERR512,XIP512,XIPTMP,X,Y,DA,D,DIQ,DIC,IENS,XIPERR,LPCODE
; if input parameter (PCODE) is less than 5 characters, quit w/error
I $L(PCODE)<5 S XIP("ERROR")="PCODE entered was less than 5 characters." Q
;
S LPCODE=$E(PCODE,1,5)
D PBC^XIPUTIL1 ; Continue processing
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXIPUTIL 7244 printed Sep 23, 2025@19:38:39 Page 2
XIPUTIL ;ALB/BRM,OIFO/SO - POSTAL AND COUNTY CODE APIS ;2:16 PM 10 Jul 2003
+1 ;;8.0;KERNEL;**246,292**;Jul 10, 1995
+2 ;
+3 ; this routine holds APIs used to extract data from the
+4 ; County Code (#5.13) and Postal Code (#5.12) files.
+5 ;
+6 QUIT
+7 ;
POSTAL(PCODE,XIP) ; return all data for the Prefered City for a postal code
+1 ;
+2 ; INPUT
+3 ; PCODE - Postal Code for which to return the data
+4 ;
+5 ; OUTPUT
+6 ; XIP("POSTAL CODE") - the value used to lookup postal data
+7 ; XIP("CITY") - the city that the USPS assigned to this PCODE
+8 ; XIP("COUNTY") - The county associated with this PCODE
+9 ; XIP("COUNTY POINTER") - pointer to the county in file #5.13
+10 ; XIP("STATE") - The state associated with this PCODE
+11 ; XIP("STATE POINTER") - pointer to the state in file #5
+12 ; XIP("CITY KEY") - USPS's assigned city key
+13 ; XIP("PREFERRED CITY KEY") - USPS's Prefered (DEFAULT) city key
+14 ; XIP("CITY ABBREVIATION") - USPS's assigned abbreviation
+15 ; XIP("UNIQUE KEY") - a unique look-up value
+16 ; XIP("FIPS CODE") - 5 digit FIPS code associated with the county
+17 ; XIP("ERROR") - returns errors encountered during look-up
+18 ;
+19 IF $GET(PCODE)']""
SET XIP("ERROR")="Missing Input Parameter"
QUIT
+20 NEW X,ERR512,XIP512,XIPTMP,X,Y,DA,D,DIQ,DIC,IENS,XIPERR,LPCODE
+21 ; initialize the XIP data array
+22 DO INITXIP(.XIP)
+23 ; initialize additional XIP subscripts
+24 FOR X="CITY","COUNTY POINTER","POSTAL CODE","CITY KEY","PREFERRED CITY KEY","CITY ABBREVIATION","UNIQUE KEY"
SET XIP(X)=""
+25 ;Inactive dates are screen out
KILL XIP("INACTIVE DATE")
+26 ; if input parameter (PCODE) is less than 5 characters, quit w/error
+27 IF $LENGTH(PCODE)<5
SET XIP("ERROR")="PCODE entered was less than 5 characters."
QUIT
+28 SET (LPCODE,XIP("POSTAL CODE"))=$EXTRACT(PCODE,1,5)
+29 SET XIP512=0
+30 Begin DoDot:1
+31 NEW DIERR,XIPERR,FIELDS,I,D512,S512
+32 SET FIELDS="@;5;6"
+33 ; Screen out INACTIVE Zip Codes
SET S512="I $P(^(0),U,5)="""""
+34 DO LIST^DIC(5.12,"",FIELDS,"P","","",LPCODE,"B",S512,"","D512","XIPERR")
+35 if $DATA(DIERR)
QUIT
+36 SET I=0
+37 FOR
SET I=$ORDER(D512("DILIST",I))
if 'I
QUIT
Begin DoDot:2
+38 IF $PIECE(D512("DILIST",I,0),"^",2)=$PIECE(D512("DILIST",I,0),"^",3)
SET XIP512=$PIECE(D512("DILIST",I,0),"^",1)
End DoDot:2
End DoDot:1
+39 IF 'XIP512
SET XIP("ERROR")="Postal Code cannot be found"
QUIT
+40 NEW X
+41 SET X=^XIP(5.12,XIP512,0)
+42 SET XIP("CITY")=$PIECE(X,"^",2)
+43 SET XIP("COUNTY POINTER")=$PIECE(X,"^",3)
+44 SET XIP("STATE POINTER")=$PIECE(X,"^",4)
+45 SET XIP("INACTIVE DATE")=$PIECE(X,"^",5)
+46 SET XIP("CITY KEY")=$PIECE(X,"^",6)
+47 SET XIP("PREFERRED CITY KEY")=$PIECE(X,"^",7)
+48 SET XIP("CITY ABBREVIATION")=$PIECE(X,"^",8)
+49 SET XIP("UNIQUE KEY")=$PIECE(X,"^",9)
+50 SET XIP("STATE")=$PIECE($GET(^DIC(5,+XIP("STATE POINTER"),0)),"^")
+51 SET XIP("COUNTY")=$PIECE($GET(^XIP(5.13,+XIP("COUNTY POINTER"),0)),"^",2)
+52 SET XIP("FIPS CODE")=$PIECE($GET(^XIP(5.13,+XIP("COUNTY POINTER"),0)),"^")
+53 QUIT
+54 ;
INITXIP(ARRY) ;initialize the county code array
+1 FOR X="COUNTY","STATE","STATE POINTER","INACTIVE DATE","FIPS CODE"
SET ARRY(X)=""
+2 QUIT
+3 ;
FIPS(PCODE) ;API to return the FIPS code associated with the postal code
+1 ;
+2 ;INPUT:
+3 ; PCODE - Postal code
+4 ;OUTPUT:
+5 ; 5 digit FIPS code associated with the entered postal code
+6 ; or "0^error message" if a processing error occurs
+7 ;
+8 if PCODE']""
QUIT "0^Missing Input Parameter"
+9 if $LENGTH(PCODE)<5
QUIT "0^Input Parameter is less than 5 characters"
+10 ;
+11 NEW IEN512,IEN513,FIPS
+12 IF $LENGTH(PCODE)>5
SET PCODE=$EXTRACT(PCODE,1,5)
+13 SET IEN512=0
+14 Begin DoDot:1
+15 NEW DIERR,XIPERR,FIELDS,XIPTMP,I
+16 SET FIELDS="@;5;6"
+17 DO LIST^DIC(5.12,"",FIELDS,"P","","",PCODE,"","","","XIPTMP","XIPERR")
+18 if $DATA(DIERR)
QUIT
+19 SET I=0
+20 FOR
SET I=$ORDER(XIPTMP("DILIST",I))
if 'I
QUIT
Begin DoDot:2
+21 IF $PIECE(XIPTMP("DILIST",I,0),"^",2)=$PIECE(XIPTMP("DILIST",I,0),"^",3)
SET IEN512=$PIECE(XIPTMP("DILIST",I,0),"^",1)
End DoDot:2
End DoDot:1
+22 if 'IEN512
QUIT "0^Postal Code not found"
+23 SET IEN513=$PIECE($GET(^XIP(5.12,IEN512,0)),"^",3)
+24 if 'IEN513
QUIT "0^County cannot be determined"
+25 SET FIPS=$$GET1^DIQ(5.13,IEN513_",",.01)
+26 if FIPS
QUIT FIPS
+27 QUIT "0^FIPS Code cannot be determined"
+28 ;
CCODE(FIPS,XIPC) ; return all data related to a FIPS county code
+1 ;
+2 ; INPUT
+3 ; FIPS - 5 digit FIPS County Code for which to return the data
+4 ;
+5 ; OUTPUT
+6 ; XIPC("FIPS CODE") - 5 digit FIPS county code
+7 ; XIPC("COUNTY") - The county associated with this FIPS code
+8 ; XIPC("STATE") - The state associated with this FIPS code
+9 ; XIPC("STATE POINTER") - pointer to the state in file #5
+10 ; XIPC("INACTIVE DATE") - date this FIPS code was inactivated
+11 ; XIPC("LATITUDE") - The estimated Latitude of the county
+12 ; XIPC("LONGITUDE") - The estimated Longitude of the county
+13 ; XIPC("ERROR") - returns errors encountered during look-up
+14 ;
+15 IF $GET(FIPS)']""
SET XIPC("ERROR")="Missing Input Parameter"
QUIT
+16 ;
+17 NEW X,XIPCTMP,XIP513,ERR513,IENS
+18 ; initialize the XIPC data array
+19 DO INITXIP(.XIPC)
+20 SET XIPC("LATITUDE")=""
SET XIPC("LONGITUDE")=""
+21 SET XIPC("FIPS CODE")=FIPS
+22 ; if input parameter (FIPS) is less than 5 characters, quit w/error
+23 IF $GET(FIPS)'?5N
SET XIPC("ERROR")="FIPS Code input parameter is not valid."
QUIT
+24 ;
+25 SET XIP513=0
+26 Begin DoDot:1
+27 NEW DIERR,XIPERR
+28 SET XIP513=$$FIND1^DIC(5.13,,"BOX",FIPS,"","","XIPERR")
End DoDot:1
+29 IF 'XIP513
Begin DoDot:1
+30 SET XIP513=$ORDER(^XIP(5.13,"B",FIPS,""))
+31 IF XIP513
SET XIPC("ERROR")="Multiple entries exist for FIPS code"
QUIT
+32 SET XIPC("ERROR")="Entered FIPS Code could not be found"
End DoDot:1
if 'XIP513
QUIT
+33 Begin DoDot:1
+34 NEW DIERR
+35 DO GETS^DIQ(5.13,XIP513_",","**","IE","XIPCTMP","ERR513")
End DoDot:1
+36 IF $DATA(ERR513)
SET XIPC("ERROR")="Error occurred while retrieving County Code data"
QUIT
+37 ;put data into array
+38 SET XIP513=XIP513_","
+39 SET XIPC("COUNTY")=$GET(XIPCTMP(5.13,XIP513,1,"E"))
+40 SET XIPC("STATE")=$GET(XIPCTMP(5.13,XIP513,2,"E"))
+41 SET XIPC("STATE POINTER")=$GET(XIPCTMP(5.13,XIP513,2,"I"))
+42 SET XIPC("INACTIVE DATE")=$GET(XIPCTMP(5.13,XIP513,3,"I"))
+43 SET XIPC("LATITUDE")=$GET(XIPCTMP(5.13,XIP513,4,"E"))
+44 SET XIPC("LONGITUDE")=$GET(XIPCTMP(5.13,XIP513,5,"E"))
+45 QUIT
FIPSCHK(FIPS) ; does this FIPS code exist?
+1 if $GET(FIPS)']""
QUIT 0
+2 if $LENGTH(FIPS)<5
QUIT 0
+3 QUIT +$ORDER(^XIP(5.13,"B",FIPS,""))
+4 ;
POSTALB(PCODE,XIP) ; return all data related to a postal code
+1 ;
+2 ; INPUT
+3 ; PCODE - Postal Code for which to return the data
+4 ;
+5 ; OUTPUT
+6 ; XIP(n) - the number of primary subscripts
+7 ; XIP(n,"POSTAL CODE") - the value used to lookup postal data
+8 ; XIP(n,"CITY") - the city that the USPS assigned to this PCODE
+9 ; XIP(n,"COUNTY") - The county associated with this PCODE
+10 ; XIP(n,"COUNTY POINTER") - pointer to the county in file #5.13
+11 ; XIP(n,"STATE") - The state associated with this PCODE
+12 ; XIP(n,"STATE POINTER") - pointer to the state in file #5
+13 ; XIP(n,"INACTIVE DATE") - date on which this PCODE was inactivated
+14 ; XIP(n"CITY KEY") - USPS's assigned city key
+15 ; XIP(n,"PREFERRED CITY KEY") - USPS's Preferred (DEFAULT) city key
+16 ; XIP(n,"CITY ABBREVIATION") - USPS's assigned abbreviation
+17 ; XIP(n,"UNIQUE KEY") - a unique look-up value
+18 ; XIP(n,"FIPS CODE") - 5 digit FIPS code associated with the county
+19 ; XIP("ERROR") - returns errors encountered during look-up
+20 ;
+21 SET XIP=0
+22 IF $GET(PCODE)']""
SET XIP("ERROR")="Missing Input Parameter"
QUIT
+23 NEW X,ERR512,XIP512,XIPTMP,X,Y,DA,D,DIQ,DIC,IENS,XIPERR,LPCODE
+24 ; if input parameter (PCODE) is less than 5 characters, quit w/error
+25 IF $LENGTH(PCODE)<5
SET XIP("ERROR")="PCODE entered was less than 5 characters."
QUIT
+26 ;
+27 SET LPCODE=$EXTRACT(PCODE,1,5)
+28 ; Continue processing
DO PBC^XIPUTIL1
+29 QUIT
