- 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 Jan 18, 2025@03:53:02 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