SDECDEM ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
;;5.3;Scheduling;**658**;Aug 13, 1993;Build 23
;
Q
;
ZIPLINK(RET,ZIP) ;GET linked cities/state/etc for given zip code
;INPUT:
; 1. ZIP - 5 or 9 digit numeric Zip code
;RETURN:
; 1. CITYNAME - City name
; 2. CITY_ABB - City Abbreviation
; 3. CITY_KEY - City Key
; 4. COUNTYNAME - County name
; 5. COUNTYIEN - County Pointer
; 6. FIPS - FIPS code
; 7. ZIP - ZIP CODE
; 8. P_CITY_KEY - Preferred City Key
; 9. STATENAME - State name
; 10. STATE_IEN - State ien
; 11. UID - Unique Key
;
N SDATA,SDECI,SDI,SDTMP,X
S SDECI=0
S RET="^TMP(""SDECDEM"","_$J_",""ZIPLINK"")"
K @RET
; data header
S SDTMP="T00030CITYNAME^T00030CITY_ABB^T00030CITY_KEY^T00030COUNTYNAME^T00030COUNTY_IEN^T00030FIPS^T00030ZIP"
S SDTMP=SDTMP_"^T00030P_CITY_KEY^T00030STATENAME^T00030STATE_IEN^T00030UID"
S @RET@(0)=SDTMP_$C(30)
;validate ZIP
S ZIP=$G(ZIP)
I ZIP'="" D
.I ($A(ZIP)=45),$L(ZIP)>20!($L(ZIP)<5) S @RET@(1)="-1^Zip code must be 5 or 9 numeric digits "_ZIP_"."_$C(30,31) Q
.S X=ZIP D ZIPIN^VAFADDR S X=$G(X) S:X'="" ZIP=X I X="" S @RET@(1)="-1^Invalid zip code "_ZIP_"."_$C(30,31) Q
;
I ZIP'="" D
.D POSTALB^XIPUTIL(ZIP,.SDATA)
.S SDI="" F S SDI=$O(SDATA(SDI)) Q:SDI="" D
..S SDTMP=$G(SDATA(SDI,"CITY"))
..S $P(SDTMP,U,2)=$G(SDATA(SDI,"CITY ABBREVIATION"))
..S $P(SDTMP,U,3)=$G(SDATA(SDI,"CITY KEY"))
..S $P(SDTMP,U,4)=$G(SDATA(SDI,"COUNTY"))
..S $P(SDTMP,U,5)=$G(SDATA(SDI,"COUNTY POINTER"))
..S $P(SDTMP,U,6)=$G(SDATA(SDI,"FIPS CODE"))
..S $P(SDTMP,U,7)=$G(SDATA(SDI,"POSTAL CODE"))
..S $P(SDTMP,U,8)=$G(SDATA(SDI,"PREFERRED CITY KEY"))
..S $P(SDTMP,U,9)=$G(SDATA(SDI,"STATE"))
..S $P(SDTMP,U,10)=$G(SDATA(SDI,"STATE POINTER"))
..S $P(SDTMP,U,11)=$G(SDATA(SDI,"UNIQUE KEY"))
..S SDECI=SDECI+1 S @RET@(SDECI)=SDTMP_$C(30)
S @RET@(SDECI)=@RET@(SDECI)_$C(31)
Q
;
MARITAL(RET) ;GET Marital status entries from the MARITAL STATUS file (#11)
;INPUT:
; none
;RETURN:
; 1. MIEN - Marital Status ID pointer to the MARITAL STATUS file (#11)
; 2. MNAME - Marital Status name
; 3. MABB - Marital Status Abbreviation
; 4. MCODE - Marital Status Code - valid values are:
; D:DIVORCED
; M:MARRIED
; N:NEVER MARRIED
; S:SEPARATED
; W:WIDOWED
; U:UNKNOWN
N MIEN,MNAME,MNOD,SDECI
S SDECI=0
S RET="^TMP(""SDECDEM"","_$J_",""MARITAL"")"
K @RET
; data header
S @RET@(0)="T00030MIEN^T00030MNAME^T00030MABB^T00030MCODE"_$C(30)
;
S MNAME="" F S MNAME=$O(^DIC(11,"B",MNAME)) Q:MNAME="" D
.S MIEN=0 F S MIEN=$O(^DIC(11,"B",MNAME,MIEN)) Q:MIEN="" D
..S MNOD=$G(^DIC(11,MIEN,0))
..Q:MNOD=""
..S SDECI=SDECI+1 S @RET@(SDECI)=MIEN_U_MNAME_U_$P(MNOD,U,2)_U_$P(MNOD,U,3)_$C(30)
S @RET@(SDECI)=@RET@(SDECI)_$C(31)
Q
;
RELIGION(RET) ;GET Religious preference entries from the RELITION file (#13)
;INPUT:
; none
;RETURN:
; 1. RIEN - Religion ID pointer to the RELIGION file (#13)
; 2. RNAME - Religion name
; 3. RABB - Religion Abbreviation
; 4. RCLASS - Religion Classification code
; 1=CATHOLIC
; 2=PROTESTANT
; 3=JEWISH
; 4=ORTHODOX
; 5=OTHER
; 5. RCLASSN - Relition Classification name
; 6. RCODE - Religion Code - Numeric 1-99
N RIEN,RNAME,RNOD,SDECI
S SDECI=0
S RET="^TMP(""SDECDEM"","_$J_",""RELIGION"")"
K @RET
; data header
S @RET@(0)="T00030RIEN^T00030RNAME^T00030RABB^T00030RCLASS^T00030RCLASSN^T00030RCODE"_$C(30)
;
S RNAME="" F S RNAME=$O(^DIC(13,"B",RNAME)) Q:RNAME="" D
.S RIEN=0 F S RIEN=$O(^DIC(13,"B",RNAME,RIEN)) Q:RIEN="" D
..S RNOD=$G(^DIC(13,RIEN,0))
..Q:RNOD=""
..S SDECI=SDECI+1 S @RET@(SDECI)=RIEN_U_RNAME_U_$P(RNOD,U,2)_U_$P(RNOD,U,3)_U_$$GET1^DIQ(13,RIEN_",",2)_U_$P(RNOD,U,4)_$C(30)
S @RET@(SDECI)=@RET@(SDECI)_$C(31)
Q
;
CITYAB(ZIP,CITY) ;GET city abbreviation for given city and zip
N CITY1,CITYAB,SDATA,SDI
S (CITY1,CITYAB)=""
S ZIP=$G(ZIP) Q:ZIP="" ""
S CITY=$G(CITY)
D POSTALB^XIPUTIL(ZIP,.SDATA)
S SDI="" F S SDI=$O(SDATA(SDI)) Q:SDI="" D Q:CITY1=CITY
.S CITY1=$G(SDATA(SDI,"CITY"))
.S CITY1=$S($E(CITY1,$L(CITY1))="*":$E(CITY1,1,$L(CITY1)-1),1:CITY1)
.S CITYAB=$G(SDATA(SDI,"CITY ABBREVIATION"))
Q CITYAB
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECDEM 4412 printed Dec 13, 2024@02:51:54 Page 2
SDECDEM ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
+1 ;;5.3;Scheduling;**658**;Aug 13, 1993;Build 23
+2 ;
+3 QUIT
+4 ;
ZIPLINK(RET,ZIP) ;GET linked cities/state/etc for given zip code
+1 ;INPUT:
+2 ; 1. ZIP - 5 or 9 digit numeric Zip code
+3 ;RETURN:
+4 ; 1. CITYNAME - City name
+5 ; 2. CITY_ABB - City Abbreviation
+6 ; 3. CITY_KEY - City Key
+7 ; 4. COUNTYNAME - County name
+8 ; 5. COUNTYIEN - County Pointer
+9 ; 6. FIPS - FIPS code
+10 ; 7. ZIP - ZIP CODE
+11 ; 8. P_CITY_KEY - Preferred City Key
+12 ; 9. STATENAME - State name
+13 ; 10. STATE_IEN - State ien
+14 ; 11. UID - Unique Key
+15 ;
+16 NEW SDATA,SDECI,SDI,SDTMP,X
+17 SET SDECI=0
+18 SET RET="^TMP(""SDECDEM"","_$JOB_",""ZIPLINK"")"
+19 KILL @RET
+20 ; data header
+21 SET SDTMP="T00030CITYNAME^T00030CITY_ABB^T00030CITY_KEY^T00030COUNTYNAME^T00030COUNTY_IEN^T00030FIPS^T00030ZIP"
+22 SET SDTMP=SDTMP_"^T00030P_CITY_KEY^T00030STATENAME^T00030STATE_IEN^T00030UID"
+23 SET @RET@(0)=SDTMP_$CHAR(30)
+24 ;validate ZIP
+25 SET ZIP=$GET(ZIP)
+26 IF ZIP'=""
Begin DoDot:1
+27 IF ($ASCII(ZIP)=45)
IF $LENGTH(ZIP)>20!($LENGTH(ZIP)<5)
SET @RET@(1)="-1^Zip code must be 5 or 9 numeric digits "_ZIP_"."_$CHAR(30,31)
QUIT
+28 SET X=ZIP
DO ZIPIN^VAFADDR
SET X=$GET(X)
if X'=""
SET ZIP=X
IF X=""
SET @RET@(1)="-1^Invalid zip code "_ZIP_"."_$CHAR(30,31)
QUIT
End DoDot:1
+29 ;
+30 IF ZIP'=""
Begin DoDot:1
+31 DO POSTALB^XIPUTIL(ZIP,.SDATA)
+32 SET SDI=""
FOR
SET SDI=$ORDER(SDATA(SDI))
if SDI=""
QUIT
Begin DoDot:2
+33 SET SDTMP=$GET(SDATA(SDI,"CITY"))
+34 SET $PIECE(SDTMP,U,2)=$GET(SDATA(SDI,"CITY ABBREVIATION"))
+35 SET $PIECE(SDTMP,U,3)=$GET(SDATA(SDI,"CITY KEY"))
+36 SET $PIECE(SDTMP,U,4)=$GET(SDATA(SDI,"COUNTY"))
+37 SET $PIECE(SDTMP,U,5)=$GET(SDATA(SDI,"COUNTY POINTER"))
+38 SET $PIECE(SDTMP,U,6)=$GET(SDATA(SDI,"FIPS CODE"))
+39 SET $PIECE(SDTMP,U,7)=$GET(SDATA(SDI,"POSTAL CODE"))
+40 SET $PIECE(SDTMP,U,8)=$GET(SDATA(SDI,"PREFERRED CITY KEY"))
+41 SET $PIECE(SDTMP,U,9)=$GET(SDATA(SDI,"STATE"))
+42 SET $PIECE(SDTMP,U,10)=$GET(SDATA(SDI,"STATE POINTER"))
+43 SET $PIECE(SDTMP,U,11)=$GET(SDATA(SDI,"UNIQUE KEY"))
+44 SET SDECI=SDECI+1
SET @RET@(SDECI)=SDTMP_$CHAR(30)
End DoDot:2
End DoDot:1
+45 SET @RET@(SDECI)=@RET@(SDECI)_$CHAR(31)
+46 QUIT
+47 ;
MARITAL(RET) ;GET Marital status entries from the MARITAL STATUS file (#11)
+1 ;INPUT:
+2 ; none
+3 ;RETURN:
+4 ; 1. MIEN - Marital Status ID pointer to the MARITAL STATUS file (#11)
+5 ; 2. MNAME - Marital Status name
+6 ; 3. MABB - Marital Status Abbreviation
+7 ; 4. MCODE - Marital Status Code - valid values are:
+8 ; D:DIVORCED
+9 ; M:MARRIED
+10 ; N:NEVER MARRIED
+11 ; S:SEPARATED
+12 ; W:WIDOWED
+13 ; U:UNKNOWN
+14 NEW MIEN,MNAME,MNOD,SDECI
+15 SET SDECI=0
+16 SET RET="^TMP(""SDECDEM"","_$JOB_",""MARITAL"")"
+17 KILL @RET
+18 ; data header
+19 SET @RET@(0)="T00030MIEN^T00030MNAME^T00030MABB^T00030MCODE"_$CHAR(30)
+20 ;
+21 SET MNAME=""
FOR
SET MNAME=$ORDER(^DIC(11,"B",MNAME))
if MNAME=""
QUIT
Begin DoDot:1
+22 SET MIEN=0
FOR
SET MIEN=$ORDER(^DIC(11,"B",MNAME,MIEN))
if MIEN=""
QUIT
Begin DoDot:2
+23 SET MNOD=$GET(^DIC(11,MIEN,0))
+24 if MNOD=""
QUIT
+25 SET SDECI=SDECI+1
SET @RET@(SDECI)=MIEN_U_MNAME_U_$PIECE(MNOD,U,2)_U_$PIECE(MNOD,U,3)_$CHAR(30)
End DoDot:2
End DoDot:1
+26 SET @RET@(SDECI)=@RET@(SDECI)_$CHAR(31)
+27 QUIT
+28 ;
RELIGION(RET) ;GET Religious preference entries from the RELITION file (#13)
+1 ;INPUT:
+2 ; none
+3 ;RETURN:
+4 ; 1. RIEN - Religion ID pointer to the RELIGION file (#13)
+5 ; 2. RNAME - Religion name
+6 ; 3. RABB - Religion Abbreviation
+7 ; 4. RCLASS - Religion Classification code
+8 ; 1=CATHOLIC
+9 ; 2=PROTESTANT
+10 ; 3=JEWISH
+11 ; 4=ORTHODOX
+12 ; 5=OTHER
+13 ; 5. RCLASSN - Relition Classification name
+14 ; 6. RCODE - Religion Code - Numeric 1-99
+15 NEW RIEN,RNAME,RNOD,SDECI
+16 SET SDECI=0
+17 SET RET="^TMP(""SDECDEM"","_$JOB_",""RELIGION"")"
+18 KILL @RET
+19 ; data header
+20 SET @RET@(0)="T00030RIEN^T00030RNAME^T00030RABB^T00030RCLASS^T00030RCLASSN^T00030RCODE"_$CHAR(30)
+21 ;
+22 SET RNAME=""
FOR
SET RNAME=$ORDER(^DIC(13,"B",RNAME))
if RNAME=""
QUIT
Begin DoDot:1
+23 SET RIEN=0
FOR
SET RIEN=$ORDER(^DIC(13,"B",RNAME,RIEN))
if RIEN=""
QUIT
Begin DoDot:2
+24 SET RNOD=$GET(^DIC(13,RIEN,0))
+25 if RNOD=""
QUIT
+26 SET SDECI=SDECI+1
SET @RET@(SDECI)=RIEN_U_RNAME_U_$PIECE(RNOD,U,2)_U_$PIECE(RNOD,U,3)_U_$$GET1^DIQ(13,RIEN_",",2)_U_$PIECE(RNOD,U,4)_$CHAR(30)
End DoDot:2
End DoDot:1
+27 SET @RET@(SDECI)=@RET@(SDECI)_$CHAR(31)
+28 QUIT
+29 ;
CITYAB(ZIP,CITY) ;GET city abbreviation for given city and zip
+1 NEW CITY1,CITYAB,SDATA,SDI
+2 SET (CITY1,CITYAB)=""
+3 SET ZIP=$GET(ZIP)
if ZIP=""
QUIT ""
+4 SET CITY=$GET(CITY)
+5 DO POSTALB^XIPUTIL(ZIP,.SDATA)
+6 SET SDI=""
FOR
SET SDI=$ORDER(SDATA(SDI))
if SDI=""
QUIT
Begin DoDot:1
+7 SET CITY1=$GET(SDATA(SDI,"CITY"))
+8 SET CITY1=$SELECT($EXTRACT(CITY1,$LENGTH(CITY1))="*":$EXTRACT(CITY1,1,$LENGTH(CITY1)-1),1:CITY1)
+9 SET CITYAB=$GET(SDATA(SDI,"CITY ABBREVIATION"))
End DoDot:1
if CITY1=CITY
QUIT
+10 QUIT CITYAB
