SDEC53 ;ALB/SAT,LAB - VISTA SCHEDULING RPCS ;Apr 10, 2020@15:22
;;5.3;Scheduling;**627,658,679,745,809**;Aug 13, 1993;Build 10
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to PREREG^VPSRPC3 (Update to 41.41) is supported by IA #5797,#4425
Q
;
PTSET(SDECY,INP) ;SET patient demographics
;SD*5.3*745 replace external 'INP...' due to XINDEX issue. Parameters are then rolled into the INP array
;PTSET(SDECY,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,S12,S13,S14,S15,S16,S17,S18,S19,S20,S21,S22,S23,S24,S25,S26,S27,S28,S29,S30,S31,S32) external parameter tag is in SDEC
;INPUT:
; all input except DFN is optional
; INP(1) = DFN - (required) pointer to PATIENT file
; INP(2) = RACE - pointer to the RACE file 10
; Each pipe piece contains the following pieces (Race1;;Method1|Race2;;Method2):
; RACE INFORMATION - pointer to the RACE file 10
; METHOD OF COLLECTION - pointer to the RACE AND ETHNICITY COLLECTION METHOD file 10.3
; INP(3) = ETHNICITY - multiple Ethnicity separated by pipe |
; Each pipe piece contains the following ;; pieces:
; ETHNICITY INFORMATION - pointer to the ETHNICITY file 10.2
; METHOD OF COLLECTION - pointer to the ETHNICITY COLLECTION METHOD file 10.3
; INP(4) = ADDRESS1 - Street Address (Line 1) Free text 3-30 characters
; INP(5) = ADDRESS2 - Street Address (Line 2) Free text 3-30 characters
; INP(6) = ADDRESS3 - Street Address (Line 3) Free text 3-30 characters
; INP(7) = ZIP CODE - Zip+4 Free text of 5 or 9 digits
; INP(8) = CITY - Free text 2-15 characters
; INP(9) = STATE - pointer to STATE file 5
; INP(10) = COUNTRY - pointer to COUNTRY CODE file 779.004
; INP(11) = BAD ADDRESS INDICATOR - Valid Values:
; UNDELIVERABLE
; HOMELESS
; OTHER
; ADDRESS NOT FOUND
; INP(12) = PHONE (RESIDENCE) - free text 4-20 characters (Phone #1)
; INP(13) = PHONE (WORK) - free text 4-20 characters
; INP(14) = COUNTY name - name of a county from the COUNTY multiple within the STATE file (#5)
; INP(15) = PHONE NUMBER [CELLULAR] 4-20 characters
; INP(16) = Patient Email Address - 3-50 characters containing 1 @
; INP(17) = Marital Status - pointer to MARITAL STATUS file (#11)
; INP(18) = Religious Preference - pointer to RELIGION file (#13)
; INP(19) = Patient Temporary Address Active? (.12105) Y:YES N:NO
; Temporary Address data can only be edited if INP(19) is 'Y' or the 'TEMPORARY ADDRESS ACTIVE?' field is already defined as 'Y'.
; INP(20) = Patient Temporary Address Line 1 (.1211)
; INP(21) = Patient Temporary Address Line 2 (.1212)
; INP(22) = Patient Temporary Address Line 3 (.1213)
; INP(23) = Patient Temporary City (.1214)
; INP(24) = Patient Temporary State (.1215)
; INP(25) = Patient Temporary Zip (.1216)
; INP(26) = Patient Temporary Zip+4 (.12112)
; INP(27) = Patient Temporary Country (.1223)
; INP(28) = Patient Temporary County (.12111)
; INP(29) = Patient Temporary Phone (.1219) (also referred to as Phone #2)
; INP(30) = Patient Temporary Address Start Date (.1217) in external format (no time)
; INP(31) = Patient Temporary Address End Date (.1218) in external format (no time)
;RETURN:
; Successful Return:
; Single Value return in the format "0^"
; Caught Exception Return:
; A single entry in the Global Array in the format "-1^<error text>"
; "T00020RETURNCODE^T00100TEXT"
; Unexpected Exception Return:
; Handled by the RPC Broker.
; M errors are trapped by the use of M and Kernel error handling.
; The RPC execution stops and the RPC Broker sends the error generated
; text back to the client.
N %DT,DIC,RET,X,Y
N ADD1,ADD2,ADD3,BADADD,CITY,COUNTRY,DA,DIK,DFN,ERR,ETH,ETHN,ETHN1,PHONER,PHONEW,RACE,STATE,ZIP
N SDECI,SDFDA,SDI,SDIN,SDMSG,RACEN,RACEN1
S ERR=0
S SDECI=0
S SDECY="^TMP(""SDEC53"","_$J_",""PTSET"")"
K @SDECY
; data header
S @SDECY@(0)="T00030RETURNCODE^T00030TEXT"_$C(30)
;check for valid Patient
S DFN=$G(INP(1))
I '+DFN D ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY) Q
I '$D(^DPT(DFN,0)) D ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY) Q
;alb/sat 658 - lock patient: There are multiple variations used to lock a patient
L +^TMP(DFN,"REGISTRATION IN PROGRESS"):5 I '$T S @SDECY@(1)="-1^Patient is being edited."_$C(30,31) G XIT
L +^DPT(DFN):5 I '$T S @SDECY@(1)="-1^Patient is being edited."_$C(30,31) L -^TMP(DFN,"REGISTRATION IN PROGRESS") G XIT
S SDFDA="SDFDA(2,DFN_"","")"
;address line 1
S INP(4)=$G(INP(4))
I INP(4)'="" D
.S X=INP(4)
.I X'="@",(X[""""!($A(X)=45))!($L(X)>35!($L(X)<3)) S @SDECY@(1)="-1^Invalid street address [line 1] "_INP(4)_"."_$C(30,31),ERR=1 Q
.S @SDFDA@(.111)=INP(4)
G:ERR EXIT ;alb/sat 658
;address line 2
S INP(5)=$G(INP(5))
I INP(5)'="" D
.N X S X=INP(5)
.I X'="@",(X[""""!($A(X)=45))!($L(X)>30!($L(X)<3)) S @SDECY@(1)="-1^Invalid street address [line 2] "_INP(5)_"."_$C(30,31),ERR=1 Q
.S @SDFDA@(.112)=INP(5)
G:ERR EXIT ;alb/sat 658
;address line 3
S INP(6)=$G(INP(6))
I INP(6)'="" D
.N X S X=INP(6)
.I X'="@",(X[""""!($A(X)=45))!($L(X)>30!($L(X)<3)) S @SDECY@(1)="-1^Invalid street address [line 3] "_INP(6)_"."_$C(30,31),ERR=1 Q
.S @SDFDA@(.113)=INP(6)
G:ERR EXIT ;alb/sat 658
;zip
S ZIP=$G(INP(7))
I ZIP'="@",ZIP'="" N X S X=ZIP D ZIPIN^VAFADDR S X=$G(X),ZIP=X I $L(ZIP)'=5,$L(ZIP)'=9 S @SDECY@(1)="-1^Invalid ZIP."_$C(30,31) G EXIT ;alb/sat 658
S:ZIP'="" @SDFDA@(.1112)=ZIP
;city
S INP(8)=$G(INP(8))
I INP(8)'="" D
.S X=INP(8)
.I $L(X)>15 S ZIP=$S($L(INP(7))'="":INP(7),1:$$GET1^DIQ(2,DFN_",",.1112)) S:ZIP'="" X=$$CITYAB^SDECDEM(ZIP,X)
.I X'="@",$L(X)>15!($L(X)<2) S @SDECY@(1)="-1^City name must be 2-15 characters. "_INP(8)_"."_$C(30,31),ERR=1 Q ;alb/jsm 658 chk for "@"
.S @SDFDA@(.114)=X
G:ERR EXIT ;alb/sat 658
;state
S STATE=$G(INP(9))
I STATE'="@",STATE'="" I '$D(^DIC(5,+STATE,0)) S @SDECY@(1)="-1^Invalid State ID."_$C(30,31) G EXIT ;alb/sat/jsm 658 chk for "@"
S:STATE'="" @SDFDA@(.115)=STATE
;country
S COUNTRY=$G(INP(10))
I COUNTRY'="@",COUNTRY'="" I '$D(^HL(779.004,+COUNTRY,0)) S @SDECY@(1)="-1^Invalid COUNTRY ID."_$C(30,31) G EXIT ;alb/sat/jsm 658 chk for "@"
S:COUNTRY'="" @SDFDA@(.1173)=COUNTRY
;bad address
S BADADD=$G(INP(11))
I BADADD'="" S:BADADD'="@" BADADD=$S(BADADD="UNDELIVERABLE":1,BADADD="HOMELESS":2,BADADD="OTHER":3,BADADD="ADDRESS NOT FOUND":4,1:"")
S:BADADD'="" @SDFDA@(.121)=BADADD
;phone [residence]
S INP(12)=$G(INP(12))
I INP(12)'="" D
.I INP(12)'="@" D
..I $L(INP(12))>20!($L(INP(12))<4) S @SDECY@(1)="-1^Phone Number [Residence] must be 4-20 characters. "_INP(12)_$C(30,31),ERR=1 Q
..;I 'ERR N CTR,CHR,VAR S VAR=INP(12) F CTR=1:1:20 S CHR=$E(VAR,CTR) I ("1234567890 -()."'[CHR) S ERR=1
..;I ERR S @SDECY@(1)="-1^Invalid Phone Number [Residence] "_INP(12)_$C(30,31),ERR=1 Q
.I 'ERR S @SDFDA@(.131)=INP(12)
G:ERR EXIT ;alb/sat 658
;phone [work]
S INP(13)=$G(INP(13))
I INP(13)'="" D
.I INP(13)'="@" D
..I $L(INP(13))>20!($L(INP(13))<4) S @SDECY@(1)="-1^Phone Number [work] must be 4-20 characters. "_INP(13)_$C(30,31),ERR=1 Q
..;I 'ERR N CTR,CHR,VAR S VAR=INP(13) F CTR=1:1:20 S CHR=$E(VAR,CTR) I ("1234567890 -()."'[CHR) S ERR=1
..;I ERR S @SDECY@(1)="-1^Invalid Phone Number [work] "_INP(13)_$C(30,31),ERR=1 Q
.I 'ERR S @SDFDA@(.132)=INP(13)
G:ERR EXIT ;alb/sat 658
;pager number .135 ;alb/sat 658
S INP(32)=$G(INP(32))
I INP(32)'="" D
.IF INP(32)'="@" D
..S X=INP(32) I $L(X)>20!($L(X)<4) S @SDECY@(1)="-1^Pager must be 4-20 characters. "_INP(32)_$C(30,31),ERR=1 Q
..I $D(X) N CTR,CHR,VAR S VAR=X F CTR=1:1:20 S CHR=$E(VAR,CTR) I ("1234567890 -()."'[CHR) S @SDECY@(1)="-1^Pager can only contain these characters: 1234567890 -()."_$C(30,31),ERR=1 Q
..S INP(32)=$G(X)
.I 'ERR S @SDFDA@(.135)=INP(32)
G:ERR EXIT ;alb/sat 658
;county
S INP(14)=$G(INP(14))
I INP(14)'="" D
.I INP(14)'="@" D ;alb/jsm 658
..N X,Z0,STNM
..S Z0=$S(STATE'="":STATE,$D(^DPT(DFN,.11)):+$P(^DPT(DFN,.11),"^",5),1:0)
..I 'Z0 S @SDECY@(1)="-1^A state must be defined to update the County."_$C(30,31),ERR=1 Q
..; ajf/ patch 679 / Corrected display of state name, add "O" and removed "E" from DIC(0)
..I $D(^DIC(5,Z0,1,0)) S STNM=$P(^DIC(5,Z0,0),"^",1),DIC="^DIC(5,Z0,1,",DIC(0)="QMO",X=INP(14) D ^DIC S X=+Y I Y'>0 S @SDECY@(1)="-1^County "_INP(14)_" does not belong to state "_STNM_"."_$C(30,31),ERR=1 Q
..S INP(14)=X
.I 'ERR S @SDFDA@(.117)=INP(14)
G:ERR EXIT ;alb/sat
;phone [cell]
S INP(15)=$G(INP(15))
I INP(15)'="" D
.I INP(15)'="@" D
..I $L(INP(15))>20!($L(INP(15))<4) S @SDECY@(1)="-1^Phone Number [Cellular] must be 4-20 characters. "_INP(15)_$C(30,31),ERR=1 Q
..I 'ERR N CTR,CHR,VAR S VAR=INP(15) F CTR=1:1:20 S CHR=$E(VAR,CTR) I ("1234567890 -()."'[CHR) S ERR=1
..I ERR S @SDECY@(1)="-1^Invalid Phone Number [Cellular] "_INP(15)_$C(30,31),ERR=1 Q
.I 'ERR S @SDFDA@(.134)=INP(15)
G:ERR EXIT ;alb/sat
;email
S INP(16)=$G(INP(16))
I INP(16)'="" D
.I INP(16)'="@" D
..N X S X=INP(16)
..I $L(X)>50!($L(X)<3)!'(X?1.E1"@"1.E1"."1.E) S @SDECY@(1)="-1^Invalid email address "_INP(16)_$C(30,31),ERR=1
.I 'ERR S @SDFDA@(.133)=INP(16)
G:ERR EXIT ;alb/sat
;marital status
S INP(17)=$G(INP(17))
I INP(17)'="" D
.I '$D(^DIC(11,INP(17),0)) S @SDECY@(1)="-1^Invalid marital status ID "_INP(17)_$C(30,31),ERR=1
.I 'ERR S @SDFDA@(.05)=INP(17)
G:ERR EXIT ;alb/sat
;religious preference
S INP(18)=$G(INP(18))
I INP(18)'="" D
.I '$D(^DIC(13,INP(18),0)) S @SDECY@(1)="-1^Invalid religious preference ID "_INP(18)_$C(30,31),ERR=1
.I 'ERR S @SDFDA@(.08)=INP(18)
G:ERR EXIT ;alb/sat
;temporary address active?
S INP(19)=$G(INP(19))
I INP(19)'="" D
.N X S X=INP(19)
.S X=$S(X="Y":"Y",X="YES":"Y",X="N":"N",X="NO":"N",1:"")
.I X="" S @SDECY@(1)="-1^Invalid 'temporary address active' flag "_INP(19)_$C(30,31),ERR=1
.I 'ERR S (INP(19),@SDFDA@(.12105))=X
G:ERR EXIT ;alb/sat
;temporary address line 1
S INP(20)=$G(INP(20))
I INP(20)'="" D
.N X S X=INP(20)
.I X'="@",(X[""""!($A(X)=45))!($L(X)>30!($L(X)<2)) S @SDECY@(1)="-1^Invalid temporary street [line 1] "_INP(20)_"."_$C(30,31),ERR=1 Q
.I X'="@",INP(19)'="Y",$S(INP(19)="N":1,'$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) S (X,INP(20))="" ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
.I INP(20)'="",'ERR S @SDFDA@(.1211)=INP(20)
G:ERR EXIT ;alb/sat
;temporary address line 2
S INP(21)=$G(INP(21))
I INP(21)'="" D
.N X S X=INP(21)
.I X'="@",(X[""""!($A(X)=45))!($L(X)>30!($L(X)<2)) S @SDECY@(1)="-1^Invalid temporary street [line 2] "_INP(21)_"."_$C(30,31),ERR=1 Q
.I X'="@",INP(19)'="Y",$S(INP(19)="N":1,'$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) S (X,INP(21))="" ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
.I INP(21)'="",'ERR S @SDFDA@(.1212)=INP(21)
G:ERR EXIT ;alb/sat
;temporary address line 3
S INP(22)=$G(INP(22))
I INP(22)'="" D
.N X S X=INP(22)
.I X'="@",(X[""""!($A(X)=45))!($L(X)>30!($L(X)<2)) S @SDECY@(1)="-1^Invalid temporary street [line 3] "_INP(22)_"."_$C(30,31),ERR=1 Q
.I X'="@",INP(19)'="Y",$S(INP(19)="N":1,'$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) S (X,INP(22))="" ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
.I INP(22)'="",'ERR S @SDFDA@(.1213)=INP(22)
G:ERR EXIT ;alb/sat
;temporary city
S INP(23)=$G(INP(23))
I INP(23)'="" D
.S X=INP(23)
.I $L(X)>30 S ZIP=$S($L(INP(25))'="":INP(25),1:$$GET1^DIQ(2,DFN_",",.12112)) S:ZIP'="" X=$$CITYAB^SDECDEM(ZIP,X)
.I X'="@",$L(X)>30!($L(X)<2) S @SDECY@(1)="-1^Invalid temporary city "_INP(23)_"."_$C(30,31),ERR=1 Q ;alb/jsm 658
.I X'="@",INP(19)'="Y",$S(INP(19)="N":1,'$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) S (X,INP(23))="" ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
.I INP(23)'="",'ERR S @SDFDA@(.1214)=X
G:ERR EXIT ;alb/sat 658
;temporary state
S INP(24)=$G(INP(24))
I INP(24)'="" D
.I INP(24)'="@",'$D(^DIC(5,INP(24),0)) S @SDECY@(1)="-1^Invalid temporary State id "_INP(24)_"."_$C(30,31),ERR=1 Q ;alb/jsm 658
.I INP(24)'="@",INP(19)'="Y",$S(INP(19)="N":1,'$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) S INP(24)="" ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
.I INP(24)'="",'ERR S @SDFDA@(.1215)=INP(24)
G:ERR EXIT ;alb/sat
;temporary zip
S INP(25)=$G(INP(25))
I INP(25)'="" D
.N X S X=INP(25)
.D ZIPIN^VAFADDR S X=$G(X)
.I X'="@",X[""""!($A(X)=45),$L(X)>5!($L(X)<5)!'(X?5N) S @SDECY@(1)="-1^Invalid Temporary Zip code "_INP(25)_"."_$C(30,31),ERR=1 Q
.I X'="@",INP(19)'="Y",$S(INP(19)="N":1,'$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) S (X,INP(25))="" ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
.I INP(25)'="",'ERR S @SDFDA@(.1216)=INP(25)
G:ERR EXIT ;alb/sat
;temporary zip+4
S INP(26)=$G(INP(26))
I INP(26)'="" D
.I INP(26)'="@" D ;alb/jsm 658
..N X S X=INP(26)
..I X'="@",X[""""!($A(X)=45),$L(X)>20!($L(X)<5) S @SDECY@(1)="-1^Invalid Temporary Zip+4 "_INP(26)_"."_$C(30,31),ERR=1 Q
..I X'="@" D ZIPIN^VAFADDR S X=$G(X) I X="" S @SDECY@(1)="-1^Invalid Temporary Zip+4 "_INP(26)_"."_$C(30,31),ERR=1 Q
..I X'="@",INP(19)'="Y",$S(INP(19)="N":1,'$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) S (X,INP(26))="" ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
.I 'ERR,INP(26)'="" S @SDFDA@(.12112)=INP(26)
G:ERR EXIT ;alb/sat 658
;temporary country
S INP(27)=$G(INP(27))
I INP(27)'="" D
.I INP(27)'="@",'$D(^HL(779.004,INP(27),0)) S @SDECY@(1)="-1^Invalid temporary country ID "_INP(27)_"."_$C(30,31),ERR=1 Q ;alb/jsm 658
.S @SDFDA@(.1223)=INP(27)
G:ERR EXIT ;alb/sat 658
;temporary county
S INP(28)=$G(INP(28))
I INP(28)'="" D
.I INP(28)'="@" D ;alb/jsm 658
..N X,Z0
..S Z0=$S(INP(24)'="":INP(24),$D(^DPT(DFN,.121)):+$P(^DPT(DFN,.121),"^",5),1:0)
..I 'Z0 S @SDECY@(1)="-1^A state must be defined to update the Temporary County."_$C(30,31),ERR=1 Q
..; ajf/ patch 679 / Corrected display of state name, add "O" and removed "E" from DIC(0)
..I $D(^DIC(5,Z0,1,0)) S STNM=$P(^DIC(5,Z0,0),"^",1),DIC="^DIC(5,Z0,1,",DIC(0)="QMO",X=INP(28) D ^DIC S X=+Y I Y'>0 S @SDECY@(1)="-1^Temporary County "_INP(28)_" does not belong to state "_STNM_"."_$C(30,31),ERR=1
..S INP(28)=X
.I 'ERR S @SDFDA@(.12111)=INP(28)
G:ERR EXIT ;alb/sat 658
;temporary phone
S INP(29)=$G(INP(29))
I INP(29)'="" D
.I INP(29)'="@" D
..I $L(INP(29))>20!($L(INP(29))<4) S @SDECY@(1)="-1^Temporary Phone must be 4-20 characters. "_INP(29)_$C(30,31),ERR=1 Q
..;I 'ERR N CTR,CHR,VAR S VAR=INP(29) F CTR=1:1:20 S CHR=$E(VAR,CTR) I ("1234567890 -()."'[CHR) S ERR=1
..;I ERR S @SDECY@(1)="-1^Invalid Temporary Phone Number "_INP(29)_$C(30,31),ERR=1 Q
.I 'ERR S @SDFDA@(.1219)=INP(29)
G:ERR EXIT ;alb/sat 658
;temporary address start date
S INP(30)=$G(INP(30))
I INP(30)'="" D
.I INP(30)'="@" D
..N X
..S %DT="E",X=INP(30) D ^%DT I Y<1 S @SDECY@(1)="-1^Invalid Temporary Address Start Date "_INP(30)_$C(30,31),ERR=1 Q
..S (INP(30),X)=Y
..I INP(30)'="@",INP(19)'="Y",$S(INP(19)="N":1,'$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) S (X,INP(30))="" ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
.I 'ERR,INP(30)'="" S @SDFDA@(.1217)=INP(30)
G:ERR EXIT ;alb/sat 658
;temporary address end date
S INP(31)=$G(INP(31))
I INP(31)'="" D
.I INP(31)'="@" D
..N X
..S %DT="E",X=INP(31) D ^%DT I Y<1 S @SDECY@(1)="-1^Invalid Temporary Address End Date "_INP(31)_$C(30,31),ERR=1 Q
..S (INP(31),X)=Y
..I INP(31)'="@",INP(19)'="Y",$S(INP(19)="N":1,'$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) S (X,INP(31))="" ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
.I 'ERR,INP(31)'="" S @SDFDA@(.1218)=INP(31)
G:ERR EXIT ;alb/sat 658
;
I $D(@SDFDA) D UPDATE^DIE("","SDFDA")
I $D(SDMSG) D ERR1^SDECERR(-1,"Error storing data.",SDECI,SDECY) Q
;RACE
S RACEN=$G(INP(2))
I RACEN'="" D
.S RACEN1="" F SDI=1:1:$L(RACEN,"|") D
..S SDIN=$P(RACEN,"|",SDI)
..I $E(SDIN)="@" D Q
...S SDIN=$E(SDIN,2,$L(SDIN))
...S RACE=$O(^DPT(DFN,.02,"B",$P(SDIN,";;"),0))
...I RACE D
....S DIK="^DPT("_DFN_",.02,"
....S DA=RACE,DA(1)=DFN
....D ^DIK
..I $D(^DIC(10,+$P(SDIN,";;"),0)) D
...I $P(SDIN,";;",2)'="",$D(^DIC(10.3,+$P(SDIN,";;",2),0)) S RACEN1=$S(RACEN1'="":RACEN1_"|",1:"")_SDIN
...I $P(SDIN,";;",2)="" S RACEN1=$S(RACEN1'="":RACEN1_"|",1:"")_SDIN
.S RACEN=RACEN1
.I RACEN'="" F SDI=1:1:$L(RACEN,"|") D
..K SDFDA
..S SDIN=$P(RACEN,"|",SDI)
..S RACE=$O(^DPT(DFN,.02,"B",$P(SDIN,";;"),0))
..S RACE=$S(RACE'="":RACE,1:"+1")
..S SDFDA="SDFDA(2.02,"_$S(RACE'="":RACE_""",""",1:"""+1")_""","_DFN_",)"
..S SDFDA=$NA(SDFDA(2.02,RACE_","_DFN_","))
..S @SDFDA@(.01)=$P(SDIN,";;")
..S:$P(SDIN,";;",2)'="" @SDFDA@(.02)=$P(SDIN,";;",2)
..D UPDATE^DIE("","SDFDA")
;ethnicity
S ETHN=$G(INP(3))
I ETHN'="" D
.S ETHN1="" F SDI=1:1:$L(ETHN,"|") D
..S SDIN=$P(ETHN,"|",SDI)
..I $E(SDIN)="@" D Q
...S SDIN=$O(^DPT(DFN,.06,"B",""))
...S ETH=$O(^DPT(DFN,.06,"B",SDIN,0))
...I ETH D
....S DIK="^DPT("_DFN_",.06,"
....S DA=ETH,DA(1)=DFN
....D ^DIK
..I $D(^DIC(10.2,+$P(SDIN,";;",1),0)) D
...I $P(SDIN,";;",2)'="",$D(^DIC(10.3,+$P(SDIN,";;",2),0)) S ETHN1=$S(ETHN1'="":ETHN1_"|",1:"")_SDIN
...I $P(SDIN,";;",2)="" S ETHN1=$S(ETHN1'="":ETHN1_"|",1:"")_SDIN
.S ETHN=ETHN1
.I ETHN'="" F SDI=1:1:$L(ETHN,"|") D
..K SDFDA
..S SDIN=$P(ETHN,"|",SDI)
..S ETH=$O(^DPT(DFN,.06,"B",$P(SDIN,";;",1),0))
..S ETH=$S(ETH'="":ETH,1:"+1")
..S SDFDA="SDFDA(2.06,"_$S(ETH'="":ETH_""",""",1:"""+1")_""","_DFN_",)"
..S SDFDA=$NA(SDFDA(2.06,ETH_","_DFN_","))
..S @SDFDA@(.01)=$P(SDIN,";;",1)
..S:$P(SDIN,";;",2)'="" @SDFDA@(.02)=$P(SDIN,";;",2)
..D UPDATE^DIE("","SDFDA")
N RTN
D PREREG^VPSRPC3(.RTN,DFN,"X") ;ICR 5797
S SDECI=SDECI+1 S @SDECY@(SDECI)="0^"_$C(30,31)
EXIT ;unlock exit ;alb/sat 658
L -^TMP(DFN,"REGISTRATION IN PROGRESS")
L -^DPT(DFN)
XIT ;alb/sat 658 - exit tag added
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC53 18593 printed Jan 18, 2025@03:51:58 Page 2
SDEC53 ;ALB/SAT,LAB - VISTA SCHEDULING RPCS ;Apr 10, 2020@15:22
+1 ;;5.3;Scheduling;**627,658,679,745,809**;Aug 13, 1993;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to PREREG^VPSRPC3 (Update to 41.41) is supported by IA #5797,#4425
+5 QUIT
+6 ;
PTSET(SDECY,INP) ;SET patient demographics
+1 ;SD*5.3*745 replace external 'INP...' due to XINDEX issue. Parameters are then rolled into the INP array
+2 ;PTSET(SDECY,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,S12,S13,S14,S15,S16,S17,S18,S19,S20,S21,S22,S23,S24,S25,S26,S27,S28,S29,S30,S31,S32) external parameter tag is in SDEC
+3 ;INPUT:
+4 ; all input except DFN is optional
+5 ; INP(1) = DFN - (required) pointer to PATIENT file
+6 ; INP(2) = RACE - pointer to the RACE file 10
+7 ; Each pipe piece contains the following pieces (Race1;;Method1|Race2;;Method2):
+8 ; RACE INFORMATION - pointer to the RACE file 10
+9 ; METHOD OF COLLECTION - pointer to the RACE AND ETHNICITY COLLECTION METHOD file 10.3
+10 ; INP(3) = ETHNICITY - multiple Ethnicity separated by pipe |
+11 ; Each pipe piece contains the following ;; pieces:
+12 ; ETHNICITY INFORMATION - pointer to the ETHNICITY file 10.2
+13 ; METHOD OF COLLECTION - pointer to the ETHNICITY COLLECTION METHOD file 10.3
+14 ; INP(4) = ADDRESS1 - Street Address (Line 1) Free text 3-30 characters
+15 ; INP(5) = ADDRESS2 - Street Address (Line 2) Free text 3-30 characters
+16 ; INP(6) = ADDRESS3 - Street Address (Line 3) Free text 3-30 characters
+17 ; INP(7) = ZIP CODE - Zip+4 Free text of 5 or 9 digits
+18 ; INP(8) = CITY - Free text 2-15 characters
+19 ; INP(9) = STATE - pointer to STATE file 5
+20 ; INP(10) = COUNTRY - pointer to COUNTRY CODE file 779.004
+21 ; INP(11) = BAD ADDRESS INDICATOR - Valid Values:
+22 ; UNDELIVERABLE
+23 ; HOMELESS
+24 ; OTHER
+25 ; ADDRESS NOT FOUND
+26 ; INP(12) = PHONE (RESIDENCE) - free text 4-20 characters (Phone #1)
+27 ; INP(13) = PHONE (WORK) - free text 4-20 characters
+28 ; INP(14) = COUNTY name - name of a county from the COUNTY multiple within the STATE file (#5)
+29 ; INP(15) = PHONE NUMBER [CELLULAR] 4-20 characters
+30 ; INP(16) = Patient Email Address - 3-50 characters containing 1 @
+31 ; INP(17) = Marital Status - pointer to MARITAL STATUS file (#11)
+32 ; INP(18) = Religious Preference - pointer to RELIGION file (#13)
+33 ; INP(19) = Patient Temporary Address Active? (.12105) Y:YES N:NO
+34 ; Temporary Address data can only be edited if INP(19) is 'Y' or the 'TEMPORARY ADDRESS ACTIVE?' field is already defined as 'Y'.
+35 ; INP(20) = Patient Temporary Address Line 1 (.1211)
+36 ; INP(21) = Patient Temporary Address Line 2 (.1212)
+37 ; INP(22) = Patient Temporary Address Line 3 (.1213)
+38 ; INP(23) = Patient Temporary City (.1214)
+39 ; INP(24) = Patient Temporary State (.1215)
+40 ; INP(25) = Patient Temporary Zip (.1216)
+41 ; INP(26) = Patient Temporary Zip+4 (.12112)
+42 ; INP(27) = Patient Temporary Country (.1223)
+43 ; INP(28) = Patient Temporary County (.12111)
+44 ; INP(29) = Patient Temporary Phone (.1219) (also referred to as Phone #2)
+45 ; INP(30) = Patient Temporary Address Start Date (.1217) in external format (no time)
+46 ; INP(31) = Patient Temporary Address End Date (.1218) in external format (no time)
+47 ;RETURN:
+48 ; Successful Return:
+49 ; Single Value return in the format "0^"
+50 ; Caught Exception Return:
+51 ; A single entry in the Global Array in the format "-1^<error text>"
+52 ; "T00020RETURNCODE^T00100TEXT"
+53 ; Unexpected Exception Return:
+54 ; Handled by the RPC Broker.
+55 ; M errors are trapped by the use of M and Kernel error handling.
+56 ; The RPC execution stops and the RPC Broker sends the error generated
+57 ; text back to the client.
+58 NEW %DT,DIC,RET,X,Y
+59 NEW ADD1,ADD2,ADD3,BADADD,CITY,COUNTRY,DA,DIK,DFN,ERR,ETH,ETHN,ETHN1,PHONER,PHONEW,RACE,STATE,ZIP
+60 NEW SDECI,SDFDA,SDI,SDIN,SDMSG,RACEN,RACEN1
+61 SET ERR=0
+62 SET SDECI=0
+63 SET SDECY="^TMP(""SDEC53"","_$JOB_",""PTSET"")"
+64 KILL @SDECY
+65 ; data header
+66 SET @SDECY@(0)="T00030RETURNCODE^T00030TEXT"_$CHAR(30)
+67 ;check for valid Patient
+68 SET DFN=$GET(INP(1))
+69 IF '+DFN
DO ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY)
QUIT
+70 IF '$DATA(^DPT(DFN,0))
DO ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY)
QUIT
+71 ;alb/sat 658 - lock patient: There are multiple variations used to lock a patient
+72 LOCK +^TMP(DFN,"REGISTRATION IN PROGRESS"):5
IF '$TEST
SET @SDECY@(1)="-1^Patient is being edited."_$CHAR(30,31)
GOTO XIT
+73 LOCK +^DPT(DFN):5
IF '$TEST
SET @SDECY@(1)="-1^Patient is being edited."_$CHAR(30,31)
LOCK -^TMP(DFN,"REGISTRATION IN PROGRESS")
GOTO XIT
+74 SET SDFDA="SDFDA(2,DFN_"","")"
+75 ;address line 1
+76 SET INP(4)=$GET(INP(4))
+77 IF INP(4)'=""
Begin DoDot:1
+78 SET X=INP(4)
+79 IF X'="@"
IF (X[""""!($ASCII(X)=45))!($LENGTH(X)>35!($LENGTH(X)<3))
SET @SDECY@(1)="-1^Invalid street address [line 1] "_INP(4)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+80 SET @SDFDA@(.111)=INP(4)
End DoDot:1
+81 ;alb/sat 658
if ERR
GOTO EXIT
+82 ;address line 2
+83 SET INP(5)=$GET(INP(5))
+84 IF INP(5)'=""
Begin DoDot:1
+85 NEW X
SET X=INP(5)
+86 IF X'="@"
IF (X[""""!($ASCII(X)=45))!($LENGTH(X)>30!($LENGTH(X)<3))
SET @SDECY@(1)="-1^Invalid street address [line 2] "_INP(5)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+87 SET @SDFDA@(.112)=INP(5)
End DoDot:1
+88 ;alb/sat 658
if ERR
GOTO EXIT
+89 ;address line 3
+90 SET INP(6)=$GET(INP(6))
+91 IF INP(6)'=""
Begin DoDot:1
+92 NEW X
SET X=INP(6)
+93 IF X'="@"
IF (X[""""!($ASCII(X)=45))!($LENGTH(X)>30!($LENGTH(X)<3))
SET @SDECY@(1)="-1^Invalid street address [line 3] "_INP(6)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+94 SET @SDFDA@(.113)=INP(6)
End DoDot:1
+95 ;alb/sat 658
if ERR
GOTO EXIT
+96 ;zip
+97 SET ZIP=$GET(INP(7))
+98 ;alb/sat 658
IF ZIP'="@"
IF ZIP'=""
NEW X
SET X=ZIP
DO ZIPIN^VAFADDR
SET X=$GET(X)
SET ZIP=X
IF $LENGTH(ZIP)'=5
IF $LENGTH(ZIP)'=9
SET @SDECY@(1)="-1^Invalid ZIP."_$CHAR(30,31)
GOTO EXIT
+99 if ZIP'=""
SET @SDFDA@(.1112)=ZIP
+100 ;city
+101 SET INP(8)=$GET(INP(8))
+102 IF INP(8)'=""
Begin DoDot:1
+103 SET X=INP(8)
+104 IF $LENGTH(X)>15
SET ZIP=$SELECT($LENGTH(INP(7))'="":INP(7),1:$$GET1^DIQ(2,DFN_",",.1112))
if ZIP'=""
SET X=$$CITYAB^SDECDEM(ZIP,X)
+105 ;alb/jsm 658 chk for "@"
IF X'="@"
IF $LENGTH(X)>15!($LENGTH(X)<2)
SET @SDECY@(1)="-1^City name must be 2-15 characters. "_INP(8)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+106 SET @SDFDA@(.114)=X
End DoDot:1
+107 ;alb/sat 658
if ERR
GOTO EXIT
+108 ;state
+109 SET STATE=$GET(INP(9))
+110 ;alb/sat/jsm 658 chk for "@"
IF STATE'="@"
IF STATE'=""
IF '$DATA(^DIC(5,+STATE,0))
SET @SDECY@(1)="-1^Invalid State ID."_$CHAR(30,31)
GOTO EXIT
+111 if STATE'=""
SET @SDFDA@(.115)=STATE
+112 ;country
+113 SET COUNTRY=$GET(INP(10))
+114 ;alb/sat/jsm 658 chk for "@"
IF COUNTRY'="@"
IF COUNTRY'=""
IF '$DATA(^HL(779.004,+COUNTRY,0))
SET @SDECY@(1)="-1^Invalid COUNTRY ID."_$CHAR(30,31)
GOTO EXIT
+115 if COUNTRY'=""
SET @SDFDA@(.1173)=COUNTRY
+116 ;bad address
+117 SET BADADD=$GET(INP(11))
+118 IF BADADD'=""
if BADADD'="@"
SET BADADD=$SELECT(BADADD="UNDELIVERABLE":1,BADADD="HOMELESS":2,BADADD="OTHER":3,BADADD="ADDRESS NOT FOUND":4,1:"")
+119 if BADADD'=""
SET @SDFDA@(.121)=BADADD
+120 ;phone [residence]
+121 SET INP(12)=$GET(INP(12))
+122 IF INP(12)'=""
Begin DoDot:1
+123 IF INP(12)'="@"
Begin DoDot:2
+124 IF $LENGTH(INP(12))>20!($LENGTH(INP(12))<4)
SET @SDECY@(1)="-1^Phone Number [Residence] must be 4-20 characters. "_INP(12)_$CHAR(30,31)
SET ERR=1
QUIT
+125 ;I 'ERR N CTR,CHR,VAR S VAR=INP(12) F CTR=1:1:20 S CHR=$E(VAR,CTR) I ("1234567890 -()."'[CHR) S ERR=1
+126 ;I ERR S @SDECY@(1)="-1^Invalid Phone Number [Residence] "_INP(12)_$C(30,31),ERR=1 Q
End DoDot:2
+127 IF 'ERR
SET @SDFDA@(.131)=INP(12)
End DoDot:1
+128 ;alb/sat 658
if ERR
GOTO EXIT
+129 ;phone [work]
+130 SET INP(13)=$GET(INP(13))
+131 IF INP(13)'=""
Begin DoDot:1
+132 IF INP(13)'="@"
Begin DoDot:2
+133 IF $LENGTH(INP(13))>20!($LENGTH(INP(13))<4)
SET @SDECY@(1)="-1^Phone Number [work] must be 4-20 characters. "_INP(13)_$CHAR(30,31)
SET ERR=1
QUIT
+134 ;I 'ERR N CTR,CHR,VAR S VAR=INP(13) F CTR=1:1:20 S CHR=$E(VAR,CTR) I ("1234567890 -()."'[CHR) S ERR=1
+135 ;I ERR S @SDECY@(1)="-1^Invalid Phone Number [work] "_INP(13)_$C(30,31),ERR=1 Q
End DoDot:2
+136 IF 'ERR
SET @SDFDA@(.132)=INP(13)
End DoDot:1
+137 ;alb/sat 658
if ERR
GOTO EXIT
+138 ;pager number .135 ;alb/sat 658
+139 SET INP(32)=$GET(INP(32))
+140 IF INP(32)'=""
Begin DoDot:1
+141 IF INP(32)'="@"
Begin DoDot:2
+142 SET X=INP(32)
IF $LENGTH(X)>20!($LENGTH(X)<4)
SET @SDECY@(1)="-1^Pager must be 4-20 characters. "_INP(32)_$CHAR(30,31)
SET ERR=1
QUIT
+143 IF $DATA(X)
NEW CTR,CHR,VAR
SET VAR=X
FOR CTR=1:1:20
SET CHR=$EXTRACT(VAR,CTR)
IF ("1234567890 -()."'[CHR)
SET @SDECY@(1)="-1^Pager can only contain these characters: 1234567890 -()."_$CHAR(30,31)
SET ERR=1
QUIT
+144 SET INP(32)=$GET(X)
End DoDot:2
+145 IF 'ERR
SET @SDFDA@(.135)=INP(32)
End DoDot:1
+146 ;alb/sat 658
if ERR
GOTO EXIT
+147 ;county
+148 SET INP(14)=$GET(INP(14))
+149 IF INP(14)'=""
Begin DoDot:1
+150 ;alb/jsm 658
IF INP(14)'="@"
Begin DoDot:2
+151 NEW X,Z0,STNM
+152 SET Z0=$SELECT(STATE'="":STATE,$DATA(^DPT(DFN,.11)):+$PIECE(^DPT(DFN,.11),"^",5),1:0)
+153 IF 'Z0
SET @SDECY@(1)="-1^A state must be defined to update the County."_$CHAR(30,31)
SET ERR=1
QUIT
+154 ; ajf/ patch 679 / Corrected display of state name, add "O" and removed "E" from DIC(0)
+155 IF $DATA(^DIC(5,Z0,1,0))
SET STNM=$PIECE(^DIC(5,Z0,0),"^",1)
SET DIC="^DIC(5,Z0,1,"
SET DIC(0)="QMO"
SET X=INP(14)
DO ^DIC
SET X=+Y
IF Y'>0
SET @SDECY@(1)="-1^County "_INP(14)_" does not belong to state "_STNM_"."_$CHAR(30,31)
SET ERR=1
QUIT
+156 SET INP(14)=X
End DoDot:2
+157 IF 'ERR
SET @SDFDA@(.117)=INP(14)
End DoDot:1
+158 ;alb/sat
if ERR
GOTO EXIT
+159 ;phone [cell]
+160 SET INP(15)=$GET(INP(15))
+161 IF INP(15)'=""
Begin DoDot:1
+162 IF INP(15)'="@"
Begin DoDot:2
+163 IF $LENGTH(INP(15))>20!($LENGTH(INP(15))<4)
SET @SDECY@(1)="-1^Phone Number [Cellular] must be 4-20 characters. "_INP(15)_$CHAR(30,31)
SET ERR=1
QUIT
+164 IF 'ERR
NEW CTR,CHR,VAR
SET VAR=INP(15)
FOR CTR=1:1:20
SET CHR=$EXTRACT(VAR,CTR)
IF ("1234567890 -()."'[CHR)
SET ERR=1
+165 IF ERR
SET @SDECY@(1)="-1^Invalid Phone Number [Cellular] "_INP(15)_$CHAR(30,31)
SET ERR=1
QUIT
End DoDot:2
+166 IF 'ERR
SET @SDFDA@(.134)=INP(15)
End DoDot:1
+167 ;alb/sat
if ERR
GOTO EXIT
+168 ;email
+169 SET INP(16)=$GET(INP(16))
+170 IF INP(16)'=""
Begin DoDot:1
+171 IF INP(16)'="@"
Begin DoDot:2
+172 NEW X
SET X=INP(16)
+173 IF $LENGTH(X)>50!($LENGTH(X)<3)!'(X?1.E1"@"1.E1"."1.E)
SET @SDECY@(1)="-1^Invalid email address "_INP(16)_$CHAR(30,31)
SET ERR=1
End DoDot:2
+174 IF 'ERR
SET @SDFDA@(.133)=INP(16)
End DoDot:1
+175 ;alb/sat
if ERR
GOTO EXIT
+176 ;marital status
+177 SET INP(17)=$GET(INP(17))
+178 IF INP(17)'=""
Begin DoDot:1
+179 IF '$DATA(^DIC(11,INP(17),0))
SET @SDECY@(1)="-1^Invalid marital status ID "_INP(17)_$CHAR(30,31)
SET ERR=1
+180 IF 'ERR
SET @SDFDA@(.05)=INP(17)
End DoDot:1
+181 ;alb/sat
if ERR
GOTO EXIT
+182 ;religious preference
+183 SET INP(18)=$GET(INP(18))
+184 IF INP(18)'=""
Begin DoDot:1
+185 IF '$DATA(^DIC(13,INP(18),0))
SET @SDECY@(1)="-1^Invalid religious preference ID "_INP(18)_$CHAR(30,31)
SET ERR=1
+186 IF 'ERR
SET @SDFDA@(.08)=INP(18)
End DoDot:1
+187 ;alb/sat
if ERR
GOTO EXIT
+188 ;temporary address active?
+189 SET INP(19)=$GET(INP(19))
+190 IF INP(19)'=""
Begin DoDot:1
+191 NEW X
SET X=INP(19)
+192 SET X=$SELECT(X="Y":"Y",X="YES":"Y",X="N":"N",X="NO":"N",1:"")
+193 IF X=""
SET @SDECY@(1)="-1^Invalid 'temporary address active' flag "_INP(19)_$CHAR(30,31)
SET ERR=1
+194 IF 'ERR
SET (INP(19),@SDFDA@(.12105))=X
End DoDot:1
+195 ;alb/sat
if ERR
GOTO EXIT
+196 ;temporary address line 1
+197 SET INP(20)=$GET(INP(20))
+198 IF INP(20)'=""
Begin DoDot:1
+199 NEW X
SET X=INP(20)
+200 IF X'="@"
IF (X[""""!($ASCII(X)=45))!($LENGTH(X)>30!($LENGTH(X)<2))
SET @SDECY@(1)="-1^Invalid temporary street [line 1] "_INP(20)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+201 ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
IF X'="@"
IF INP(19)'="Y"
IF $SELECT(INP(19)="N":1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
SET (X,INP(20))=""
+202 IF INP(20)'=""
IF 'ERR
SET @SDFDA@(.1211)=INP(20)
End DoDot:1
+203 ;alb/sat
if ERR
GOTO EXIT
+204 ;temporary address line 2
+205 SET INP(21)=$GET(INP(21))
+206 IF INP(21)'=""
Begin DoDot:1
+207 NEW X
SET X=INP(21)
+208 IF X'="@"
IF (X[""""!($ASCII(X)=45))!($LENGTH(X)>30!($LENGTH(X)<2))
SET @SDECY@(1)="-1^Invalid temporary street [line 2] "_INP(21)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+209 ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
IF X'="@"
IF INP(19)'="Y"
IF $SELECT(INP(19)="N":1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
SET (X,INP(21))=""
+210 IF INP(21)'=""
IF 'ERR
SET @SDFDA@(.1212)=INP(21)
End DoDot:1
+211 ;alb/sat
if ERR
GOTO EXIT
+212 ;temporary address line 3
+213 SET INP(22)=$GET(INP(22))
+214 IF INP(22)'=""
Begin DoDot:1
+215 NEW X
SET X=INP(22)
+216 IF X'="@"
IF (X[""""!($ASCII(X)=45))!($LENGTH(X)>30!($LENGTH(X)<2))
SET @SDECY@(1)="-1^Invalid temporary street [line 3] "_INP(22)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+217 ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
IF X'="@"
IF INP(19)'="Y"
IF $SELECT(INP(19)="N":1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
SET (X,INP(22))=""
+218 IF INP(22)'=""
IF 'ERR
SET @SDFDA@(.1213)=INP(22)
End DoDot:1
+219 ;alb/sat
if ERR
GOTO EXIT
+220 ;temporary city
+221 SET INP(23)=$GET(INP(23))
+222 IF INP(23)'=""
Begin DoDot:1
+223 SET X=INP(23)
+224 IF $LENGTH(X)>30
SET ZIP=$SELECT($LENGTH(INP(25))'="":INP(25),1:$$GET1^DIQ(2,DFN_",",.12112))
if ZIP'=""
SET X=$$CITYAB^SDECDEM(ZIP,X)
+225 ;alb/jsm 658
IF X'="@"
IF $LENGTH(X)>30!($LENGTH(X)<2)
SET @SDECY@(1)="-1^Invalid temporary city "_INP(23)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+226 ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
IF X'="@"
IF INP(19)'="Y"
IF $SELECT(INP(19)="N":1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
SET (X,INP(23))=""
+227 IF INP(23)'=""
IF 'ERR
SET @SDFDA@(.1214)=X
End DoDot:1
+228 ;alb/sat 658
if ERR
GOTO EXIT
+229 ;temporary state
+230 SET INP(24)=$GET(INP(24))
+231 IF INP(24)'=""
Begin DoDot:1
+232 ;alb/jsm 658
IF INP(24)'="@"
IF '$DATA(^DIC(5,INP(24),0))
SET @SDECY@(1)="-1^Invalid temporary State id "_INP(24)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+233 ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
IF INP(24)'="@"
IF INP(19)'="Y"
IF $SELECT(INP(19)="N":1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
SET INP(24)=""
+234 IF INP(24)'=""
IF 'ERR
SET @SDFDA@(.1215)=INP(24)
End DoDot:1
+235 ;alb/sat
if ERR
GOTO EXIT
+236 ;temporary zip
+237 SET INP(25)=$GET(INP(25))
+238 IF INP(25)'=""
Begin DoDot:1
+239 NEW X
SET X=INP(25)
+240 DO ZIPIN^VAFADDR
SET X=$GET(X)
+241 IF X'="@"
IF X[""""!($ASCII(X)=45)
IF $LENGTH(X)>5!($LENGTH(X)<5)!'(X?5N)
SET @SDECY@(1)="-1^Invalid Temporary Zip code "_INP(25)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+242 ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
IF X'="@"
IF INP(19)'="Y"
IF $SELECT(INP(19)="N":1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
SET (X,INP(25))=""
+243 IF INP(25)'=""
IF 'ERR
SET @SDFDA@(.1216)=INP(25)
End DoDot:1
+244 ;alb/sat
if ERR
GOTO EXIT
+245 ;temporary zip+4
+246 SET INP(26)=$GET(INP(26))
+247 IF INP(26)'=""
Begin DoDot:1
+248 ;alb/jsm 658
IF INP(26)'="@"
Begin DoDot:2
+249 NEW X
SET X=INP(26)
+250 IF X'="@"
IF X[""""!($ASCII(X)=45)
IF $LENGTH(X)>20!($LENGTH(X)<5)
SET @SDECY@(1)="-1^Invalid Temporary Zip+4 "_INP(26)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+251 IF X'="@"
DO ZIPIN^VAFADDR
SET X=$GET(X)
IF X=""
SET @SDECY@(1)="-1^Invalid Temporary Zip+4 "_INP(26)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+252 ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
IF X'="@"
IF INP(19)'="Y"
IF $SELECT(INP(19)="N":1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
SET (X,INP(26))=""
End DoDot:2
+253 IF 'ERR
IF INP(26)'=""
SET @SDFDA@(.12112)=INP(26)
End DoDot:1
+254 ;alb/sat 658
if ERR
GOTO EXIT
+255 ;temporary country
+256 SET INP(27)=$GET(INP(27))
+257 IF INP(27)'=""
Begin DoDot:1
+258 ;alb/jsm 658
IF INP(27)'="@"
IF '$DATA(^HL(779.004,INP(27),0))
SET @SDECY@(1)="-1^Invalid temporary country ID "_INP(27)_"."_$CHAR(30,31)
SET ERR=1
QUIT
+259 SET @SDFDA@(.1223)=INP(27)
End DoDot:1
+260 ;alb/sat 658
if ERR
GOTO EXIT
+261 ;temporary county
+262 SET INP(28)=$GET(INP(28))
+263 IF INP(28)'=""
Begin DoDot:1
+264 ;alb/jsm 658
IF INP(28)'="@"
Begin DoDot:2
+265 NEW X,Z0
+266 SET Z0=$SELECT(INP(24)'="":INP(24),$DATA(^DPT(DFN,.121)):+$PIECE(^DPT(DFN,.121),"^",5),1:0)
+267 IF 'Z0
SET @SDECY@(1)="-1^A state must be defined to update the Temporary County."_$CHAR(30,31)
SET ERR=1
QUIT
+268 ; ajf/ patch 679 / Corrected display of state name, add "O" and removed "E" from DIC(0)
+269 IF $DATA(^DIC(5,Z0,1,0))
SET STNM=$PIECE(^DIC(5,Z0,0),"^",1)
SET DIC="^DIC(5,Z0,1,"
SET DIC(0)="QMO"
SET X=INP(28)
DO ^DIC
SET X=+Y
IF Y'>0
SET @SDECY@(1)="-1^Temporary County "_INP(28)_" does not belong to state "_STNM_"."_$CHAR(30,31)
SET ERR=1
+270 SET INP(28)=X
End DoDot:2
+271 IF 'ERR
SET @SDFDA@(.12111)=INP(28)
End DoDot:1
+272 ;alb/sat 658
if ERR
GOTO EXIT
+273 ;temporary phone
+274 SET INP(29)=$GET(INP(29))
+275 IF INP(29)'=""
Begin DoDot:1
+276 IF INP(29)'="@"
Begin DoDot:2
+277 IF $LENGTH(INP(29))>20!($LENGTH(INP(29))<4)
SET @SDECY@(1)="-1^Temporary Phone must be 4-20 characters. "_INP(29)_$CHAR(30,31)
SET ERR=1
QUIT
+278 ;I 'ERR N CTR,CHR,VAR S VAR=INP(29) F CTR=1:1:20 S CHR=$E(VAR,CTR) I ("1234567890 -()."'[CHR) S ERR=1
+279 ;I ERR S @SDECY@(1)="-1^Invalid Temporary Phone Number "_INP(29)_$C(30,31),ERR=1 Q
End DoDot:2
+280 IF 'ERR
SET @SDFDA@(.1219)=INP(29)
End DoDot:1
+281 ;alb/sat 658
if ERR
GOTO EXIT
+282 ;temporary address start date
+283 SET INP(30)=$GET(INP(30))
+284 IF INP(30)'=""
Begin DoDot:1
+285 IF INP(30)'="@"
Begin DoDot:2
+286 NEW X
+287 SET %DT="E"
SET X=INP(30)
DO ^%DT
IF Y<1
SET @SDECY@(1)="-1^Invalid Temporary Address Start Date "_INP(30)_$CHAR(30,31)
SET ERR=1
QUIT
+288 SET (INP(30),X)=Y
+289 ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
IF INP(30)'="@"
IF INP(19)'="Y"
IF $SELECT(INP(19)="N":1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
SET (X,INP(30))=""
End DoDot:2
+290 IF 'ERR
IF INP(30)'=""
SET @SDFDA@(.1217)=INP(30)
End DoDot:1
+291 ;alb/sat 658
if ERR
GOTO EXIT
+292 ;temporary address end date
+293 SET INP(31)=$GET(INP(31))
+294 IF INP(31)'=""
Begin DoDot:1
+295 IF INP(31)'="@"
Begin DoDot:2
+296 NEW X
+297 SET %DT="E"
SET X=INP(31)
DO ^%DT
IF Y<1
SET @SDECY@(1)="-1^Invalid Temporary Address End Date "_INP(31)_$CHAR(30,31)
SET ERR=1
QUIT
+298 SET (INP(31),X)=Y
+299 ; S @SDECY@(1)="-1^Requirement for Temporary Address data not indicated...NO EDITING!",ERR=1 Q
IF INP(31)'="@"
IF INP(19)'="Y"
IF $SELECT(INP(19)="N":1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
SET (X,INP(31))=""
End DoDot:2
+300 IF 'ERR
IF INP(31)'=""
SET @SDFDA@(.1218)=INP(31)
End DoDot:1
+301 ;alb/sat 658
if ERR
GOTO EXIT
+302 ;
+303 IF $DATA(@SDFDA)
DO UPDATE^DIE("","SDFDA")
+304 IF $DATA(SDMSG)
DO ERR1^SDECERR(-1,"Error storing data.",SDECI,SDECY)
QUIT
+305 ;RACE
+306 SET RACEN=$GET(INP(2))
+307 IF RACEN'=""
Begin DoDot:1
+308 SET RACEN1=""
FOR SDI=1:1:$LENGTH(RACEN,"|")
Begin DoDot:2
+309 SET SDIN=$PIECE(RACEN,"|",SDI)
+310 IF $EXTRACT(SDIN)="@"
Begin DoDot:3
+311 SET SDIN=$EXTRACT(SDIN,2,$LENGTH(SDIN))
+312 SET RACE=$ORDER(^DPT(DFN,.02,"B",$PIECE(SDIN,";;"),0))
+313 IF RACE
Begin DoDot:4
+314 SET DIK="^DPT("_DFN_",.02,"
+315 SET DA=RACE
SET DA(1)=DFN
+316 DO ^DIK
End DoDot:4
End DoDot:3
QUIT
+317 IF $DATA(^DIC(10,+$PIECE(SDIN,";;"),0))
Begin DoDot:3
+318 IF $PIECE(SDIN,";;",2)'=""
IF $DATA(^DIC(10.3,+$PIECE(SDIN,";;",2),0))
SET RACEN1=$SELECT(RACEN1'="":RACEN1_"|",1:"")_SDIN
+319 IF $PIECE(SDIN,";;",2)=""
SET RACEN1=$SELECT(RACEN1'="":RACEN1_"|",1:"")_SDIN
End DoDot:3
End DoDot:2
+320 SET RACEN=RACEN1
+321 IF RACEN'=""
FOR SDI=1:1:$LENGTH(RACEN,"|")
Begin DoDot:2
+322 KILL SDFDA
+323 SET SDIN=$PIECE(RACEN,"|",SDI)
+324 SET RACE=$ORDER(^DPT(DFN,.02,"B",$PIECE(SDIN,";;"),0))
+325 SET RACE=$SELECT(RACE'="":RACE,1:"+1")
+326 SET SDFDA="SDFDA(2.02,"_$SELECT(RACE'="":RACE_""",""",1:"""+1")_""","_DFN_",)"
+327 SET SDFDA=$NAME(SDFDA(2.02,RACE_","_DFN_","))
+328 SET @SDFDA@(.01)=$PIECE(SDIN,";;")
+329 if $PIECE(SDIN,";;",2)'=""
SET @SDFDA@(.02)=$PIECE(SDIN,";;",2)
+330 DO UPDATE^DIE("","SDFDA")
End DoDot:2
End DoDot:1
+331 ;ethnicity
+332 SET ETHN=$GET(INP(3))
+333 IF ETHN'=""
Begin DoDot:1
+334 SET ETHN1=""
FOR SDI=1:1:$LENGTH(ETHN,"|")
Begin DoDot:2
+335 SET SDIN=$PIECE(ETHN,"|",SDI)
+336 IF $EXTRACT(SDIN)="@"
Begin DoDot:3
+337 SET SDIN=$ORDER(^DPT(DFN,.06,"B",""))
+338 SET ETH=$ORDER(^DPT(DFN,.06,"B",SDIN,0))
+339 IF ETH
Begin DoDot:4
+340 SET DIK="^DPT("_DFN_",.06,"
+341 SET DA=ETH
SET DA(1)=DFN
+342 DO ^DIK
End DoDot:4
End DoDot:3
QUIT
+343 IF $DATA(^DIC(10.2,+$PIECE(SDIN,";;",1),0))
Begin DoDot:3
+344 IF $PIECE(SDIN,";;",2)'=""
IF $DATA(^DIC(10.3,+$PIECE(SDIN,";;",2),0))
SET ETHN1=$SELECT(ETHN1'="":ETHN1_"|",1:"")_SDIN
+345 IF $PIECE(SDIN,";;",2)=""
SET ETHN1=$SELECT(ETHN1'="":ETHN1_"|",1:"")_SDIN
End DoDot:3
End DoDot:2
+346 SET ETHN=ETHN1
+347 IF ETHN'=""
FOR SDI=1:1:$LENGTH(ETHN,"|")
Begin DoDot:2
+348 KILL SDFDA
+349 SET SDIN=$PIECE(ETHN,"|",SDI)
+350 SET ETH=$ORDER(^DPT(DFN,.06,"B",$PIECE(SDIN,";;",1),0))
+351 SET ETH=$SELECT(ETH'="":ETH,1:"+1")
+352 SET SDFDA="SDFDA(2.06,"_$SELECT(ETH'="":ETH_""",""",1:"""+1")_""","_DFN_",)"
+353 SET SDFDA=$NAME(SDFDA(2.06,ETH_","_DFN_","))
+354 SET @SDFDA@(.01)=$PIECE(SDIN,";;",1)
+355 if $PIECE(SDIN,";;",2)'=""
SET @SDFDA@(.02)=$PIECE(SDIN,";;",2)
+356 DO UPDATE^DIE("","SDFDA")
End DoDot:2
End DoDot:1
+357 NEW RTN
+358 ;ICR 5797
DO PREREG^VPSRPC3(.RTN,DFN,"X")
+359 SET SDECI=SDECI+1
SET @SDECY@(SDECI)="0^"_$CHAR(30,31)
EXIT ;unlock exit ;alb/sat 658
+1 LOCK -^TMP(DFN,"REGISTRATION IN PROGRESS")
+2 LOCK -^DPT(DFN)
XIT ;alb/sat 658 - exit tag added
+1 QUIT
