SDECAR2 ;ALB/SAT/JSM,WTC,LAB,JAS,LAB/JAS,TJB - VISTA SCHEDULING RPCS ; JUNE 20, 2025
;;5.3;Scheduling;**627,642,658,671,686,694,745,799,805,820,823,893,895,915**;Aug 13, 1993;Build 2
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
ARSET(RET,INP) ;Appt Req Set
;ARSET(RET,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)
; INP - Input parameters array
; INP(1) = (integer) Wait List IEN point to SDEC APPT REQUEST file 409.85. If null, a new entry will be added
; INP(2) = (text) DFN Pointer to the PATIENT file 2
; INP(3) = (date) Originating Date/time in external date form
; INP(4) = (text) Institution name NAME field from the INSTITUTION file
; INP(5) = (text) Request Type
; INP(6) = (text) REQ Specific Clinic name - NAME field in file 44
; INP(7) = (text) Originating User name - NAME field in NEW PERSON file 200
; INP(8) = (text) Priority - 'ASAP' or 'FUTURE'
; INP(9) = (text) Request By - 'PROVIDER' or 'PATIENT'
; INP(10) = (text) Provider name - NAME field in NEW PERSON file200
; INP(11) = (date) Desired Date of appointment in external format.
; INP(12) = (text) comment must be 1-60 characters.
; INP(13) = (text) ENROLLMENT PRIORITY - Valid Values: GROUP 1-8
; INP(14) = (text) MULTIPLE APPOINTMENT RTC NO; YES
; INP(15) = (integer) MULT APPT RTC INTERVAL integer between 1-365
; INP(16) = (integer) MULT APPT NUMBER integer between 1-100
; INP(17) = Patient Contacts separated by ::
; Each :: piece has the following ~~ pieces:
; 1) = (date) DATE ENTERED external date/time
; 2) = (text) PC ENTERED BY USER ID or NAME - Pointer toNEW PERSON file or NAME
; 4) = (optional) ACTION - valid values are: CALLED;MESSAGE LEFT;LETTER
; 5) = (optional) PATIENT PHONE Free-Text 4-20 characters
; 6) = NOT USED (optional) Comment 1-160 characters
; INP(18) = (optional) SERVICE CONNECTED PRIORITY valid values are NO YES
; INP(19) = (optional) SERVICE CONNECTED PERCENTAGE = numeric 0-100
; INP(20) = (optional) MRTC calculated preferred dates separated by pipe |: Each date can be in external format with no time.
; INP(21) = (optional) CLINIC STOP pointer to CLINIC STOP file 40.7 used to populate the REQ SERVICE/SPECIALTY field in 409.85
; INP(22) = (optional) Appointment Type ID pointer to APPOINTMENT TYPE file 409.1
; INP(23) = (optional) Patient Status: N = NEW, E = ESTABLISHED
; INP(24) = (optional) MULT APPTS MADE
; list of child pointers to SDEC APPOINTMENT and/orSDEC APPT REQUEST files separated by pipe
; each pipe piece contains the following ~ pieces:
; 1. Appointment Id pointer to SDEC APPOINTMENT file 409.84
; 2. Request Id pointer to SDEC APPT REQUEST file 409.85
; INP(25) = (optional) PARENT REQUEST pointer to SDEC APPT REQUEST file 409.85
; INP(26) = (optional) NLT (No later than) [CPRS RTC REQUIREMENT]
; INP(27) = (optional) PREREQ (Prerequisites) [CPRS RTC REQUIREMENT]
; INP(28) = (optional) ORDER IEN [CPRS RTC REQUIREMENT]
; INP(29) = (optional) VAOS GUID
;
N X,Y,%DT
N DFN,MI,ARAPTYP,ARIEN,ARORIGDT,ARORIGDTI,ARINST,ARINSTI,ARTYPE,ARTEAM,ARPOS,ARSRVSP,ARCLIN
N ARUSER,ARPRIO,ARREQBY,ARPROV,ARDAPTDT,ARCOMM,AREESTAT,AREDT,ARQUIT
N FNUM,FDA,ARNEW,ARRET,ARMSG,ARDATA,ARERR,ARHOSN,AUDF,SDREC
N ARMAI,ARMAN,ARMAR,ARPARENT,ARPATTEL,ARENPRI,ARSTOP,ARSVCCON,ARSVCCOP,PIDHIEN,PIDCHECK,VAOSGUID
S (ARQUIT,AUDF)=0
S FNUM=$$FNUM^SDECAR
S RET="I00020ERRORID^T00030ERRORTEXT"_$C(30)
M ARIEN=INP(1)
S DFN=$G(INP(2))
I '+DFN S RET=RET_"-1^Invalid Patient ID."_$C(30,31) Q
I '$D(^DPT(DFN,0)) S RET=RET_"-1^Invalid Patient ID"_$C(30,31) Q
S AREDT=$P($G(INP(3)),":",1,2)
S AREDT=$$NETTOFM^SDECDATE(AREDT,$S(AREDT["@":"Y",1:"N")) ;
I AREDT=-1 S RET=RET_"-1^Invalid Origination date."_$C(30,31) Q
S ARORIGDT=$P(AREDT,".",1)
S ARINST=$G(INP(4)) I ARINST'="" D
.I '+ARINST S ARINST=$O(^DIC(4,"B",ARINST,0))
M ARTYPE=INP(5)
S ARCLIN=$G(INP(6))
I ARCLIN'="" D
.I +ARCLIN=ARCLIN D
..I '$D(^SC(+ARCLIN,0)) S RET=RET_"-1^"_ARCLIN_" is an invalid Clinic ID."_$C(30,31) S ARQUIT=1 Q
.I '(+ARCLIN=ARCLIN) D
..S ARCLIN=$O(^SC("B",ARCLIN,0))
..I ARCLIN="" S RET=RET_"-1^"_ARCLIN_" is an invalid Clinic Name."_$C(30,31) S ARQUIT=1 Q
Q:ARQUIT=1
S ARUSER=$G(INP(7))
I ARUSER'="" I '+ARUSER S ARUSER=$O(^VA(200,"B",ARUSER,0))
I ARUSER="" S ARUSER=DUZ
S ARREQBY=$G(INP(9)) I ARREQBY'="" D
.S ARREQBY=$S(ARREQBY="PATIENT":2,ARREQBY="PROVIDER":1,1:"")
S ARPROV=$G(INP(10)) I ARPROV'="" I '+ARPROV S ARPROV=$O(^VA(200,"B",ARPROV,0))
S ARDAPTDT=INP(11)
S %DT="" S X=$P($G(ARDAPTDT),"@",1) D ^%DT S ARPRIO=$S(Y=$P($$NOW^XLFDT,".",1):"A",1:"F")
S ARDAPTDT=Y
I Y=-1 S ARDAPTDT=""
S (INP(12),ARCOMM)=$TR($G(INP(12)),"^"," ")
S ARENPRI=$G(INP(13)) D
.S:ARENPRI'="" ARENPRI=$S(ARENPRI="GROUP 1":1,ARENPRI="GROUP 2":2,ARENPRI="GROUP3":3,ARENPRI="GROUP4":4,ARENPRI="GROUP 5":5,ARENPRI="GROUP 6":6,ARENPRI="GROUP 7":7,ARENPRI="GROUP 8":8,1:ARENPRI)
S ARMAR=$G(INP(14)) I ARMAR'="" S ARMAR=$S(ARMAR="YES":1,1:0)
M ARMAI=INP(15)
M ARMAN=INP(16)
S ARSVCCON=$G(INP(18)) S:ARSVCCON'="" ARSVCCON=$S(ARSVCCON="YES":1,1:0)
M ARSVCCOP=INP(19) I $G(ARSVCCOP)'="" S ARSVCCOP=+$G(ARSVCCOP) S:(+ARSVCCOP<0)!(+ARSVCCOP>100) ARSVCCOP=""
S ARSTOP=$G(INP(21))
I ARSTOP'="",ARCLIN'="" S RET=RET_"-1^Cannot include both Clinic and Service."_$C(30,31) Q
S ARAPTYP=+$G(INP(22)) I +ARAPTYP,'$D(^SD(409.1,ARAPTYP,0)) S ARAPTYP=""
S ARPARENT=+$G(INP(25)) I +ARPARENT,'$D(^SDEC(409.85,+ARPARENT,0)) S ARPARENT=""
S ARNLT=+$G(INP(26))
S ARPRER=$G(INP(27))
S ARORDN=+$G(INP(28))
I +ARPARENT>0&(+$G(INP(26))=0) D
.S ARNLT=$P($G(^SDEC(409.85,+ARPARENT,7)),U,2)
I +ARPARENT>0&($G(INP(27))="") D
.N PRIEN,PR
.S PRIEN=0 F S PRIEN=$O(^SDEC(409.85,+ARPARENT,8,PRIEN)) Q:PRIEN'>0 D
..S PR=$P($G(^SDEC(409.85,+ARPARENT,8,PRIEN,0)),"^") Q:PR=""
..S ARPRER=$S(ARPRER'="":ARPRER_";"_PR,1:PR)
I +ARPARENT>0&(+$G(INP(28))=0) D
.S ARORDN=$P($G(^SDEC(409.85,+ARPARENT,7)),U,1)
S VAOSGUID=$G(INP(29))
S ARIEN=$G(ARIEN)
S ARNEW=ARIEN=""
N LASTNOTE S LASTNOTE=""
I ARNEW D
. S AUDF=1
. S FDA=$NA(FDA(FNUM,"+1,"))
. S @FDA@(.01)=+DFN
. S:$G(ARORIGDT)'="" @FDA@(1)=ARORIGDT
. S:$G(ARINST)'="" @FDA@(2)=+ARINST
. S:$G(ARTYPE)'="" @FDA@(4)=$S(ARTYPE="APPOINTMENT":"APPT",1:ARTYPE) ;
. S:$G(VAOSGUID)'="" @FDA@(5)=VAOSGUID
. S:$G(ARCLIN)'="" @FDA@(8)=+ARCLIN
. S:$G(ARSTOP)'="" @FDA@(8.5)=+ARSTOP
. S:+ARAPTYP @FDA@(8.7)=+ARAPTYP
. S:$G(ARUSER)'="" @FDA@(9)=+ARUSER
. S:$G(AREDT)'="" @FDA@(9.5)=AREDT
. S:$G(ARPRIO)'="" @FDA@(10)=ARPRIO
. S:$G(ARENPRI)'="" @FDA@(10.5)=ARENPRI
. S:$G(ARREQBY)'="" @FDA@(11)=ARREQBY
. S:$G(ARPROV)'="" @FDA@(12)=+ARPROV
. S:$G(ARSVCCOP)'="" @FDA@(14)=ARSVCCOP
. S:$G(ARSVCCON)'="" @FDA@(15)=+ARSVCCON
. S:$G(ARDAPTDT)'="" @FDA@(22)=ARDAPTDT
. S:$G(ARNLT)'="" @FDA@(47)=ARNLT
. D FDAPRER(.FDA,ARPRER,"+1")
. S:(+$G(ARORDN)'=0) @FDA@(46)=ARORDN
. S @FDA@(23)="O"
. I $G(ARCOMM)'="" D
. . S ARCOMM=$$CTRL^XMXUTIL1(ARCOMM)
. . S @FDA@(25)=ARCOMM
. S:$G(ARMAR)'="" @FDA@(41)=ARMAR
. I +ARMAR,$G(ARMAI)'="" S @FDA@(42)=ARMAI
. I +ARMAR,$G(ARMAN)'="" S @FDA@(43)=ARMAN
. S:$G(INP(23))'="" @FDA@(.02)=$S(INP(23)="N":"N",INP(23)="NEW":"N",INP(23)="E":"E",INP(23)="ESTABLISHED":"E",1:"")
. I $G(ARPARENT) D
. . S @FDA@(43.1)=$$MRTCHILDSEQUENCE($G(ARPARENT),$G(DFN))
. S:+ARPARENT @FDA@(43.8)=+ARPARENT
. ; initial PID change allowed field set to no.
. S @FDA@(49)=0
E D
. S ARIEN=ARIEN_","
. K ARDATA,ARERR
. D GETS^DIQ(FNUM,ARIEN,"*","IE","ARDATA","ARERR")
. I $D(ARERR) M ARMSG=ARERR K FDA Q
. S FDA=$NA(FDA(FNUM,ARIEN))
. I $D(ARORIGDT) D
. . S ARORIGDT=$P(ARORIGDT,"@",1) S %DT="" S X=ARORIGDT D ^%DT S ARORIGDTI=Y
. . I ARORIGDTI'=ARDATA(FNUM,ARIEN,1,"I") S @FDA@(1)=$S(ARORIGDT="":"@",1:ARORIGDT)
. I $D(ARINST),ARINST'=ARDATA(FNUM,ARIEN,2,"I") S @FDA@(2)=+ARINST
. I $D(ARTYPE),ARTYPE'=ARDATA(FNUM,ARIEN,4,"E") S @FDA@(4)=$S(ARTYPE="APPOINTMENT":"APPT",ARTYPE="MOBILE":"MOBILE",1:ARTYPE)
. I $G(VAOSGUID)'="",VAOSGUID'=ARDATA(FNUM,ARIEN,5,"I") S @FDA@(5)=VAOSGUID
. I ARCLIN'="",ARCLIN'=ARDATA(FNUM,ARIEN,8,"I") S @FDA@(8)=+ARCLIN,AUDF=1 S:ARDATA(FNUM,ARIEN,8.5,"I")'="" @FDA@(8.5)="@"
. I ARSTOP'="",ARSTOP'=ARDATA(FNUM,ARIEN,8.5,"I") S @FDA@(8.5)=+ARSTOP,AUDF=1 S:ARDATA(FNUM,ARIEN,8,"I")'="" @FDA@(8)="@"
. S:+ARAPTYP @FDA@(8.7)=+ARAPTYP
. I $D(ARUSER),ARUSER'=ARDATA(FNUM,ARIEN,9,"I") S @FDA@(9)=+ARUSER
. I $D(AREDT),AREDT'=$G(ARDATA(FNUM,ARIEN,9.5,"I")) S @FDA@(9.5)=AREDT
. I $D(ARPRIO),ARPRIO'=ARDATA(FNUM,ARIEN,10,"I") S @FDA@(10)=$S(ARPRIO="":"@",1:ARPRIO)
. I $D(ARENPRI),ARENPRI'=ARDATA(FNUM,ARIEN,10.5,"E") S @FDA@(10.5)=ARENPRI
. I $D(ARREQBY),ARREQBY'=ARDATA(FNUM,ARIEN,11,"I") S @FDA@(11)=$S(ARREQBY="":"@",1:ARREQBY)
. I $D(ARPROV),ARPROV'=ARDATA(FNUM,ARIEN,12,"I") S @FDA@(12)=+ARPROV
. I $D(ARSVCCOP),ARSVCCOP'=$G(ARDATA(FNUM,ARIEN,14,"I")) S @FDA@(14)=ARSVCCOP
. I $D(ARSVCCON),ARSVCCON'=ARDATA(FNUM,ARIEN,15,"E") S @FDA@(15)=+ARSVCCON
. I $D(ARDAPTDT),ARDAPTDT'=ARDATA(FNUM,ARIEN,22,"I") S @FDA@(22)=$S(ARDAPTDT="":"@",1:ARDAPTDT)
. I $D(ARCOMM),ARCOMM'=ARDATA(FNUM,ARIEN,25,"I") D
. . S LASTNOTE=ARDATA(FNUM,ARIEN,25,"I")
. . S ARCOMM=$$CTRL^XMXUTIL1(ARCOMM)
. . S @FDA@(25)=$S(ARCOMM="":"@",1:ARCOMM)
. S:$G(ARMAR)'="" @FDA@(41)=ARMAR
. S:$G(ARMAI)'="" @FDA@(42)=ARMAI
. S:$G(ARMAN)'="" @FDA@(43)=ARMAN
. S:$G(ARNLT)'="" @FDA@(47)=ARNLT
. D DELPRER(+ARIEN)
. D FDAPRER(.FDA,ARPRER,+ARIEN)
. S:+$G(ARORDN)'=0 @FDA@(46)=ARORDN
. S:$G(INP(23))'="" @FDA@(.02)=$S(INP(23)="N":"N",INP(23)="NEW":"N",INP(23)="E":"E",INP(23)="ESTABLISHED":"E",1:"")
. S:+ARPARENT @FDA@(43.8)=+ARPARENT
; Only call UPDATE^DIE if there are any array entries in FDA
D:$D(FDA)>9 UPDATE^DIE("","FDA","ARRET","ARMSG")
; Add PID History entry for appt req
S AREQIEN=$S($G(ARIEN):ARIEN,1:$G(ARRET(1)))
; 409.85 COMMENTS AUDIT multiple
I $L(ARCOMM),$L(AREQIEN) D
. N LASTLENGTH,NEWLENGTH,NEWNOTE
. S NEWNOTE=ARCOMM
. I $L(LASTNOTE) D
. . S LASTLENGTH=$L(LASTNOTE),NEWLENGTH=$L(ARCOMM)
. . S:NEWNOTE[LASTNOTE NEWNOTE=$E(ARCOMM,(LASTLENGTH+1),NEWLENGTH)
. S:$E(NEWNOTE,1,1)=" " NEWNOTE=$E(NEWNOTE,2,$L(NEWNOTE))
. N CAFDA
. S CAFDA(409.8527,"+1,"_+AREQIEN_",",.01)=$$NOW^XLFDT
. S CAFDA(409.8527,"+1,"_+AREQIEN_",",1)=$S($G(ARUSER):ARUSER,1:DUZ)
. S CAFDA(409.8527,"+1,"_+AREQIEN_",",2)=NEWNOTE
. D UPDATE^DIE("","CAFDA") K CAFDA
I $G(ARDAPTDT) D
.S ARRET=$G(ARRET(1))
.I $G(ARIEN) S ARRET=ARIEN S ARRET=$TR(ARRET,",","") S PIDCHECK=$$LASTPIDCHECK(ARRET,ARDAPTDT)
.I $G(PIDCHECK)=0 Q
.S ARUSER=$$GET1^DIQ(200,ARUSER,.01,"E")
.S FDA(409.854,"+1,"_ARRET_",",.01)=$$NOW^XLFDT
.S FDA(409.854,"+1,"_ARRET_",",1)=ARDAPTDT
.S FDA(409.854,"+1,"_ARRET_",",2)=ARUSER
.D UPDATE^DIE(,"FDA","PIDHIEN","ERR") K FDA
I $D(ARMSG) D
. F MI=1:1:$G(ARMSG("DIERR")) S RET=RET_"-1^"_$G(ARMSG("DIERR",MI,"TEXT",1))_$C(30)
. S RET=RET_$C(31)
Q:$D(ARMSG)
S ARINSTI=$P($G(^SDEC(409.85,$S(+ARIEN:ARIEN,1:ARRET(1)),0)),U,3)
I $G(INP(17))'="" D AR23(INP(17),$S(+ARIEN:ARIEN,1:ARRET(1)))
I +ARMAR,$G(INP(20))'="" D AR435(INP(20),$S(+ARIEN:ARIEN,1:ARRET(1)))
I +AUDF D ARAUD($S(+ARIEN:+ARIEN,1:ARRET(1)),ARCLIN,ARSTOP) ;VS AUDIT
I $G(INP(24))'="" N SDI F SDI=1:1:$L(INP(24),"|") S SDREC=$P(INP(24),"|",SDI) D AR433($S(+ARIEN:+ARIEN,1:ARRET(1)),SDREC)
I +ARPARENT D AR433(+ARPARENT,"~"_$S(+ARIEN:+ARIEN,1:ARRET(1)))
I +$G(ARRET(1)) S RET=RET_ARRET(1)_U_$C(30,31)
E S RET=RET_+ARIEN_U_$C(30,31)
Q
;
LASTPIDCHECK(AREQIEN,ARDAPTDT) ; check PID HISTORY
; check if last PID in PID HISTORY mult is different from incoming PID
N LASTPIDIEN,LASTPID
S LASTPIDIEN=$O(^SDEC(409.85,AREQIEN,10,"A"),-1)
S LASTPID=$$GET1^DIQ(409.854,LASTPIDIEN_","_AREQIEN_",",1,"I")
I LASTPID=ARDAPTDT Q 0
Q 1
FDAPRER(FDA,ARPRER,ARIEN) ;
N ASEQ,DELIM,PC,PR
Q:$G(ARPRER)=""
S DELIM=";",ASEQ=80
F PC=1:1:$L(ARPRER,DELIM) D
.S PR=$P(ARPRER,DELIM,PC) Q:PR=""
.S ASEQ=ASEQ+1,FDA(409.8548,"+"_ASEQ_","_ARIEN_",",.01)=PR
Q
DELPRER(ARIEN) ; clear mult field #48
;Delete all entries in PREREQUISITE mult (#48)
N DIK,DA
Q:$G(ARIEN)'=+$G(ARIEN) Q:ARIEN'>0
S DIK="^SDEC(409.85,"_ARIEN_",8,",DA(1)=ARIEN
S DA=0 F S DA=$O(^SDEC(409.85,ARIEN,8,DA)) Q:DA'>0 D ^DIK
Q
GETPRER(RET,ARIEN) ;
N CC,PR
I $G(^SDEC(409.85,+$G(ARIEN),0))="" S RET="-1^Invalid SDEC APPT REQUEST id "_$G(ARIEN) Q
S RET=""
S CC=0 F S CC=$O(^SDEC(409.85,ARIEN,8,CC)) Q:CC'>0 D
.S PR=$P($G(^SDEC(409.85,ARIEN,8,CC,0)),U,1) Q:PR=""
.S RET=$S(RET'="":RET_U_PR,1:PR)
Q
ARAUD(ARIEN,ARCLIN,ARSTOP,DATE,USER) ;populate VS AUDIT mult (#45)
N SDFDA,SDP,SDPN
S ARIEN=$G(ARIEN) Q:ARIEN=""
S ARCLIN=$G(ARCLIN)
S ARSTOP=$G(ARSTOP)
S SDP=$O(^SDEC(409.85,ARIEN,6,9999999),-1)
I +SDP S SDPN=^SDEC(409.85,ARIEN,6,SDP,0) I $P(SDPN,U,3)=ARCLIN,$P(SDPN,U,4)=ARSTOP Q
S DATE=$G(DATE) S:DATE="" DATE=$E($$NOW^XLFDT,1,12)
S USER=$G(USER) S:USER="" USER=DUZ
S SDFDA(409.8545,"+1,"_ARIEN_",",.01)=DATE
S SDFDA(409.8545,"+1,"_ARIEN_",",1)=USER
S:ARCLIN'="" SDFDA(409.8545,"+1,"_ARIEN_",",2)=ARCLIN
S:ARSTOP'="" SDFDA(409.8545,"+1,"_ARIEN_",",3)=ARSTOP
D UPDATE^DIE("","SDFDA")
Q
AR433(ARIEN,SDEC) ;set MULT APPTS MADE
; ARIEN = (required) pointer to 409.85
; SDEC = (required) child pointers to 409.84 and 409.85 separated by pipe
; each pipe piece contains the following ~ pieces:
; 1. Appointment Id pointer to 409.84
; 2. Request Id pointer to 409.85
N SDAPP,SDFDA,SDI,SDIEN
S ARIEN=$G(ARIEN)
Q:'$D(^SDEC(409.85,ARIEN,0))
S SDEC=$G(SDEC)
F SDI=1:1:$L(SDEC,"|") D
.K SDFDA
.S SDAPP=$P(SDEC,"|",SDI)
.I $P(SDAPP,"~",2)="",$P(SDAPP,"~",1)'="" S $P(SDAPP,"~",2)=$P($$GET1^DIQ(409.84,+SDAPP_",",.22,"I"),";",1)
.Q:$P(SDAPP,"~",2)=""
.S SDIEN=$O(^SDEC(409.85,ARIEN,2,"B",$P(SDAPP,"~",2),0))
.S SDIEN=$S(SDIEN'="":SDIEN,1:"+1")
.I $D(^SDEC(409.85,+$P(SDAPP,"~",2),0)) S SDFDA(409.852,SDIEN_","_ARIEN_",",.01)=+$P(SDAPP,"~",2)
.I $D(^SDEC(409.84,+$P(SDAPP,"~",1),0)) S SDFDA(409.852,SDIEN_","_ARIEN_",",.02)=+$P(SDAPP,"~",1)
.D:$D(SDFDA) UPDATE^DIE("","SDFDA")
Q
AR433D(SDEC) ;delete MULT APPTS MADE
;SDEC = (required) pointers to 409.84 separated by pipe
N ARIEN,DFN,DIEN,SDAPP,SDFDA,SDI,SDJ,SDTYP,REOPEN,PARENREQ,PARSTAT
S SDEC=$G(SDEC)
F SDI=1:1:$L(SDEC,"|") D
.S SDAPP=$P(SDEC,"|",SDI)
.Q:'$D(^SDEC(409.84,SDAPP,0))
.S REOPEN=$$GET1^DIQ(409.2,$$GET1^DIQ(409.84,SDAPP,.122,"I"),5,"I")
.S DFN=$$GET1^DIQ(409.84,SDAPP_",",.05,"I")
.S SDTYP=$$GET1^DIQ(409.84,SDAPP_",",.22,"I"),DIEN=$P(SDTYP,";",1)
.I $P(SDTYP,";",2)="SDEC(409.85," S ARIEN="" F S ARIEN=$O(^SDEC(409.85,"B",DFN,ARIEN)) Q:ARIEN="" D
..S SDJ="" F S SDJ=$O(^SDEC(409.85,ARIEN,2,"B",DIEN,SDJ)) Q:SDJ="" D
...S SDFDA(409.852,SDJ_","_ARIEN_",",.02)="@"
...D UPDATE^DIE("","SDFDA") K SDFDA
...S PARENREQ=$$GET1^DIQ(409.85,DIEN,43.8,"I")
...S PARSTAT=$$GET1^DIQ(409.85,PARENREQ,23,"I")
...I PARSTAT="C",REOPEN D
....S SDFDA(409.85,PARENREQ_",",19)=""
....S SDFDA(409.85,PARENREQ_",",20)=""
....S SDFDA(409.85,PARENREQ_",",21)=""
....S SDFDA(409.85,PARENREQ_",",23)="O"
....D FILE^DIE("","SDFDA","PARENTERR") K SDFDA
Q
;
AR438(ARIEN,SDPARENT,SDEC) ;set PARENT REQUEST (#43.8)
N SDFDA
I $G(SDPARENT)'="" S SDFDA(409.85,ARIEN_",",43.8)=SDPARENT D UPDATE^DIE("","SDFDA")
Q
AR435(SDDT,ARIEN) ;
; ARIEN - Requested date ID pointer to 409.85
; SDDT - MRTC calculated preferred dates separated by pipe |:
; Each date can be in external format with no time.
N SDI,SDJ,SDFDA,X,Y,%DT
F SDI=1:1:$L(SDDT,"|") D
.S %DT="" S X=$P($P(SDDT,"|",SDI),"@",1) D ^%DT S SDJ=Y
.Q:SDJ=-1
.Q:$O(^SDEC(409.85,ARIEN,5,"B",SDJ,0)) ;don't add duplicates
.S SDFDA(409.851,"+1,"_ARIEN_",",.01)=SDJ
.D UPDATE^DIE("","SDFDA")
Q
WLACT(NAME) ;
N ACTIVE,H
S ACTIVE=""
S H="" F S H=$O(^DIC(40.7,"B",NAME,H)) Q:H="" D Q:ACTIVE'=""
.I $P(^DIC(40.7,H,0),U,3)'="",$P(^DIC(40.7,H,0),U,3)<$$NOW^XLFDT() Q
.S ACTIVE=H
Q ACTIVE
AR23(INP17,ARI) ;Patient Contacts
N STR17,ARASD,ARASDH,ARDATA1,ARERR1,ARI1,ARIENS,ARIENS1,ARRET1,FDA
N ARDT,ARUSR,X,Y,%DT
S ARIENS=ARI_","
F ARI1=1:1:$L(INP17,"::") D
.S STR17=$P(INP17,"::",ARI1)
.K FDA
. S ARASD=$P($P(STR17,"~~",1),":",1,2),ARASD=$$NETTOFM^SDECDATE(ARASD,"Y")
.I (ARASD=-1)!(ARASD="") Q
.S ARDT=$P($P(STR17,"~~",1),":",1,2)
.S ARASDH=""
.S ARIENS1=$S(ARASDH'="":ARASDH,1:"+1")_","_ARIENS
.S FDA=$NA(FDA(409.8544,ARIENS1))
.I ARASDH'="" D
..D GETS^DIQ(409.8544,ARIENS1,"*","IE","ARDATA1","ARERR1")
..I $P(STR17,"~~",1)'="" S @FDA@(.01)=ARDT
..I $P(STR17,"~~",2)'="" S ARUSR=$P(STR17,"~~",2) S @FDA@(2)=$S(ARUSR="":"@",+ARUSR:$P($G(^VA(200,ARUSR,0)),U,1),1:ARUSER)
..I $P(STR17,"~~",4)'="" S @FDA@(3)=$P(STR17,"~~",4)
..I $P(STR17,"~~",5)'="" S @FDA@(4)=$P(STR17,"~~",5)
.I ARASDH="" D
..I $P(STR17,"~~",1)'="" S @FDA@(.01)=ARDT
..I $P(STR17,"~~",2)'="" S ARUSR=$P(STR17,"~~",2) S @FDA@(2)=$S(ARUSR="":"@",+ARUSR:$P($G(^VA(200,ARUSR,0)),U,1),1:ARUSR)
..I $P(STR17,"~~",4)'="" S @FDA@(3)=$P(STR17,"~~",4)
..I $P(STR17,"~~",5)'="" S @FDA@(4)=$P(STR17,"~~",5)
.D:$D(@FDA) UPDATE^DIE("E","FDA","ARRET1","ARMSG1")
Q
UPDATE(ARIEN,APPDT,SDCL,SVCP,SVCPR,NOTE,SDAPPTYP,EAS) ;update 409.85 with appt info
; ARIEN = Appt Request pointer to 409.85
; APPDT = Appointment date/time (Scheduled Date of appt) in fm format
; SDCL = Clinic ID pointer to file 44
; SVCP = Service Connected % numeric 0-100
; SVCPR = Service Connected Priority 0:NO 1:YES
; NOTE = Comment only 1st 60 characters are used
; SDAPPTYP = (optional) Appointment type ID pointer to file 409.1
; EAS = (optional) Enterprise Appointment Scheduling Tracking Number associated to an appointment.
;all input must be verified by calling routine
N SDDIV,SDFDA,SDSN,SDMSG
S:+$G(SDAPPTYP) SDFDA(409.85,ARIEN_",",8.7)=SDAPPTYP
S SDFDA(409.85,ARIEN_",",13)=APPDT ;
S SDFDA(409.85,ARIEN_",",13.1)=$P($$NOW^XLFDT,".",1) ;
S SDFDA(409.85,ARIEN_",",13.2)=SDCL ;
S SDFDA(409.85,ARIEN_",",13.3)=$P($G(^SC(SDCL,0)),U,4) ;
S SDFDA(409.85,ARIEN_",",13.4)=$P($G(^SC(SDCL,0)),U,7) ;
S SDDIV=$P($G(^SC(SDCL,0)),U,15)
S SDSN=$S(SDDIV'="":$P($G(^DG(40.8,SDDIV,0)),U,2),1:"")
S SDFDA(409.85,ARIEN_",",13.6)=SDSN ;
S SDFDA(409.85,ARIEN_",",13.7)=DUZ ;
S SDFDA(409.85,ARIEN_",",13.8)="R" ;
S:SVCP'="" SDFDA(409.85,ARIEN_",",14)=SVCP ;
S:SVCPR'="" SDFDA(409.85,ARIEN_",",15)=SVCPR ;
S:$G(NOTE)'="" SDFDA(409.85,ARIEN_",",25)=NOTE
S:$G(EAS)'="" SDFDA(409.85,ARIEN_",",100)=EAS
D UPDATE^DIE("","SDFDA","","SDMSG")
Q
MRTCHILDSEQUENCE(PARENTREQUESTIEN,DFN) ; next child
; return next sequence number for child mrtc
N COUNT,REQUESTIEN,IENS,NEXTSEQUENCENUM,CHILD,LASTCHILD
S REQUESTIEN=0,COUNT=0,LASTCHILD=""
F S REQUESTIEN=$O(^SDEC(409.85,"B",DFN,REQUESTIEN)) Q:'REQUESTIEN D
.I $$GET1^DIQ(409.85,REQUESTIEN,43.8,"I")=PARENTREQUESTIEN D
..S COUNT=COUNT+1
..S CHILD(REQUESTIEN)=COUNT
I $D(CHILD) D
.S LASTCHILD=$O(CHILD(LASTCHILD),-1)
.S NEXTSEQUENCENUM=$G(CHILD($G(LASTCHILD)))+1
I '$D(CHILD) S NEXTSEQUENCENUM=1
Q NEXTSEQUENCENUM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECAR2 19271 printed Sep 23, 2025@20:28:11 Page 2
SDECAR2 ;ALB/SAT/JSM,WTC,LAB,JAS,LAB/JAS,TJB - VISTA SCHEDULING RPCS ; JUNE 20, 2025
+1 ;;5.3;Scheduling;**627,642,658,671,686,694,745,799,805,820,823,893,895,915**;Aug 13, 1993;Build 2
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
ARSET(RET,INP) ;Appt Req Set
+1 ;ARSET(RET,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)
+2 ; INP - Input parameters array
+3 ; INP(1) = (integer) Wait List IEN point to SDEC APPT REQUEST file 409.85. If null, a new entry will be added
+4 ; INP(2) = (text) DFN Pointer to the PATIENT file 2
+5 ; INP(3) = (date) Originating Date/time in external date form
+6 ; INP(4) = (text) Institution name NAME field from the INSTITUTION file
+7 ; INP(5) = (text) Request Type
+8 ; INP(6) = (text) REQ Specific Clinic name - NAME field in file 44
+9 ; INP(7) = (text) Originating User name - NAME field in NEW PERSON file 200
+10 ; INP(8) = (text) Priority - 'ASAP' or 'FUTURE'
+11 ; INP(9) = (text) Request By - 'PROVIDER' or 'PATIENT'
+12 ; INP(10) = (text) Provider name - NAME field in NEW PERSON file200
+13 ; INP(11) = (date) Desired Date of appointment in external format.
+14 ; INP(12) = (text) comment must be 1-60 characters.
+15 ; INP(13) = (text) ENROLLMENT PRIORITY - Valid Values: GROUP 1-8
+16 ; INP(14) = (text) MULTIPLE APPOINTMENT RTC NO; YES
+17 ; INP(15) = (integer) MULT APPT RTC INTERVAL integer between 1-365
+18 ; INP(16) = (integer) MULT APPT NUMBER integer between 1-100
+19 ; INP(17) = Patient Contacts separated by ::
+20 ; Each :: piece has the following ~~ pieces:
+21 ; 1) = (date) DATE ENTERED external date/time
+22 ; 2) = (text) PC ENTERED BY USER ID or NAME - Pointer toNEW PERSON file or NAME
+23 ; 4) = (optional) ACTION - valid values are: CALLED;MESSAGE LEFT;LETTER
+24 ; 5) = (optional) PATIENT PHONE Free-Text 4-20 characters
+25 ; 6) = NOT USED (optional) Comment 1-160 characters
+26 ; INP(18) = (optional) SERVICE CONNECTED PRIORITY valid values are NO YES
+27 ; INP(19) = (optional) SERVICE CONNECTED PERCENTAGE = numeric 0-100
+28 ; INP(20) = (optional) MRTC calculated preferred dates separated by pipe |: Each date can be in external format with no time.
+29 ; INP(21) = (optional) CLINIC STOP pointer to CLINIC STOP file 40.7 used to populate the REQ SERVICE/SPECIALTY field in 409.85
+30 ; INP(22) = (optional) Appointment Type ID pointer to APPOINTMENT TYPE file 409.1
+31 ; INP(23) = (optional) Patient Status: N = NEW, E = ESTABLISHED
+32 ; INP(24) = (optional) MULT APPTS MADE
+33 ; list of child pointers to SDEC APPOINTMENT and/orSDEC APPT REQUEST files separated by pipe
+34 ; each pipe piece contains the following ~ pieces:
+35 ; 1. Appointment Id pointer to SDEC APPOINTMENT file 409.84
+36 ; 2. Request Id pointer to SDEC APPT REQUEST file 409.85
+37 ; INP(25) = (optional) PARENT REQUEST pointer to SDEC APPT REQUEST file 409.85
+38 ; INP(26) = (optional) NLT (No later than) [CPRS RTC REQUIREMENT]
+39 ; INP(27) = (optional) PREREQ (Prerequisites) [CPRS RTC REQUIREMENT]
+40 ; INP(28) = (optional) ORDER IEN [CPRS RTC REQUIREMENT]
+41 ; INP(29) = (optional) VAOS GUID
+42 ;
+43 NEW X,Y,%DT
+44 NEW DFN,MI,ARAPTYP,ARIEN,ARORIGDT,ARORIGDTI,ARINST,ARINSTI,ARTYPE,ARTEAM,ARPOS,ARSRVSP,ARCLIN
+45 NEW ARUSER,ARPRIO,ARREQBY,ARPROV,ARDAPTDT,ARCOMM,AREESTAT,AREDT,ARQUIT
+46 NEW FNUM,FDA,ARNEW,ARRET,ARMSG,ARDATA,ARERR,ARHOSN,AUDF,SDREC
+47 NEW ARMAI,ARMAN,ARMAR,ARPARENT,ARPATTEL,ARENPRI,ARSTOP,ARSVCCON,ARSVCCOP,PIDHIEN,PIDCHECK,VAOSGUID
+48 SET (ARQUIT,AUDF)=0
+49 SET FNUM=$$FNUM^SDECAR
+50 SET RET="I00020ERRORID^T00030ERRORTEXT"_$CHAR(30)
+51 MERGE ARIEN=INP(1)
+52 SET DFN=$GET(INP(2))
+53 IF '+DFN
SET RET=RET_"-1^Invalid Patient ID."_$CHAR(30,31)
QUIT
+54 IF '$DATA(^DPT(DFN,0))
SET RET=RET_"-1^Invalid Patient ID"_$CHAR(30,31)
QUIT
+55 SET AREDT=$PIECE($GET(INP(3)),":",1,2)
+56 ;
SET AREDT=$$NETTOFM^SDECDATE(AREDT,$SELECT(AREDT["@":"Y",1:"N"))
+57 IF AREDT=-1
SET RET=RET_"-1^Invalid Origination date."_$CHAR(30,31)
QUIT
+58 SET ARORIGDT=$PIECE(AREDT,".",1)
+59 SET ARINST=$GET(INP(4))
IF ARINST'=""
Begin DoDot:1
+60 IF '+ARINST
SET ARINST=$ORDER(^DIC(4,"B",ARINST,0))
End DoDot:1
+61 MERGE ARTYPE=INP(5)
+62 SET ARCLIN=$GET(INP(6))
+63 IF ARCLIN'=""
Begin DoDot:1
+64 IF +ARCLIN=ARCLIN
Begin DoDot:2
+65 IF '$DATA(^SC(+ARCLIN,0))
SET RET=RET_"-1^"_ARCLIN_" is an invalid Clinic ID."_$CHAR(30,31)
SET ARQUIT=1
QUIT
End DoDot:2
+66 IF '(+ARCLIN=ARCLIN)
Begin DoDot:2
+67 SET ARCLIN=$ORDER(^SC("B",ARCLIN,0))
+68 IF ARCLIN=""
SET RET=RET_"-1^"_ARCLIN_" is an invalid Clinic Name."_$CHAR(30,31)
SET ARQUIT=1
QUIT
End DoDot:2
End DoDot:1
+69 if ARQUIT=1
QUIT
+70 SET ARUSER=$GET(INP(7))
+71 IF ARUSER'=""
IF '+ARUSER
SET ARUSER=$ORDER(^VA(200,"B",ARUSER,0))
+72 IF ARUSER=""
SET ARUSER=DUZ
+73 SET ARREQBY=$GET(INP(9))
IF ARREQBY'=""
Begin DoDot:1
+74 SET ARREQBY=$SELECT(ARREQBY="PATIENT":2,ARREQBY="PROVIDER":1,1:"")
End DoDot:1
+75 SET ARPROV=$GET(INP(10))
IF ARPROV'=""
IF '+ARPROV
SET ARPROV=$ORDER(^VA(200,"B",ARPROV,0))
+76 SET ARDAPTDT=INP(11)
+77 SET %DT=""
SET X=$PIECE($GET(ARDAPTDT),"@",1)
DO ^%DT
SET ARPRIO=$SELECT(Y=$PIECE($$NOW^XLFDT,".",1):"A",1:"F")
+78 SET ARDAPTDT=Y
+79 IF Y=-1
SET ARDAPTDT=""
+80 SET (INP(12),ARCOMM)=$TRANSLATE($GET(INP(12)),"^"," ")
+81 SET ARENPRI=$GET(INP(13))
Begin DoDot:1
+82 if ARENPRI'=""
SET ARENPRI=$SELECT(ARENPRI="GROUP 1":1,ARENPRI="GROUP 2":2,ARENPRI="GROUP3":3,ARENPRI="GROUP4":4,ARENPRI="GROUP 5":5,ARENPRI="GROUP 6":6,ARENPRI="GROUP 7":7,ARENPRI="GROUP 8":8,1:ARENPRI)
End DoDot:1
+83 SET ARMAR=$GET(INP(14))
IF ARMAR'=""
SET ARMAR=$SELECT(ARMAR="YES":1,1:0)
+84 MERGE ARMAI=INP(15)
+85 MERGE ARMAN=INP(16)
+86 SET ARSVCCON=$GET(INP(18))
if ARSVCCON'=""
SET ARSVCCON=$SELECT(ARSVCCON="YES":1,1:0)
+87 MERGE ARSVCCOP=INP(19)
IF $GET(ARSVCCOP)'=""
SET ARSVCCOP=+$GET(ARSVCCOP)
if (+ARSVCCOP<0)!(+ARSVCCOP>100)
SET ARSVCCOP=""
+88 SET ARSTOP=$GET(INP(21))
+89 IF ARSTOP'=""
IF ARCLIN'=""
SET RET=RET_"-1^Cannot include both Clinic and Service."_$CHAR(30,31)
QUIT
+90 SET ARAPTYP=+$GET(INP(22))
IF +ARAPTYP
IF '$DATA(^SD(409.1,ARAPTYP,0))
SET ARAPTYP=""
+91 SET ARPARENT=+$GET(INP(25))
IF +ARPARENT
IF '$DATA(^SDEC(409.85,+ARPARENT,0))
SET ARPARENT=""
+92 SET ARNLT=+$GET(INP(26))
+93 SET ARPRER=$GET(INP(27))
+94 SET ARORDN=+$GET(INP(28))
+95 IF +ARPARENT>0&(+$GET(INP(26))=0)
Begin DoDot:1
+96 SET ARNLT=$PIECE($GET(^SDEC(409.85,+ARPARENT,7)),U,2)
End DoDot:1
+97 IF +ARPARENT>0&($GET(INP(27))="")
Begin DoDot:1
+98 NEW PRIEN,PR
+99 SET PRIEN=0
FOR
SET PRIEN=$ORDER(^SDEC(409.85,+ARPARENT,8,PRIEN))
if PRIEN'>0
QUIT
Begin DoDot:2
+100 SET PR=$PIECE($GET(^SDEC(409.85,+ARPARENT,8,PRIEN,0)),"^")
if PR=""
QUIT
+101 SET ARPRER=$SELECT(ARPRER'="":ARPRER_";"_PR,1:PR)
End DoDot:2
End DoDot:1
+102 IF +ARPARENT>0&(+$GET(INP(28))=0)
Begin DoDot:1
+103 SET ARORDN=$PIECE($GET(^SDEC(409.85,+ARPARENT,7)),U,1)
End DoDot:1
+104 SET VAOSGUID=$GET(INP(29))
+105 SET ARIEN=$GET(ARIEN)
+106 SET ARNEW=ARIEN=""
+107 NEW LASTNOTE
SET LASTNOTE=""
+108 IF ARNEW
Begin DoDot:1
+109 SET AUDF=1
+110 SET FDA=$NAME(FDA(FNUM,"+1,"))
+111 SET @FDA@(.01)=+DFN
+112 if $GET(ARORIGDT)'=""
SET @FDA@(1)=ARORIGDT
+113 if $GET(ARINST)'=""
SET @FDA@(2)=+ARINST
+114 ;
if $GET(ARTYPE)'=""
SET @FDA@(4)=$SELECT(ARTYPE="APPOINTMENT":"APPT",1:ARTYPE)
+115 if $GET(VAOSGUID)'=""
SET @FDA@(5)=VAOSGUID
+116 if $GET(ARCLIN)'=""
SET @FDA@(8)=+ARCLIN
+117 if $GET(ARSTOP)'=""
SET @FDA@(8.5)=+ARSTOP
+118 if +ARAPTYP
SET @FDA@(8.7)=+ARAPTYP
+119 if $GET(ARUSER)'=""
SET @FDA@(9)=+ARUSER
+120 if $GET(AREDT)'=""
SET @FDA@(9.5)=AREDT
+121 if $GET(ARPRIO)'=""
SET @FDA@(10)=ARPRIO
+122 if $GET(ARENPRI)'=""
SET @FDA@(10.5)=ARENPRI
+123 if $GET(ARREQBY)'=""
SET @FDA@(11)=ARREQBY
+124 if $GET(ARPROV)'=""
SET @FDA@(12)=+ARPROV
+125 if $GET(ARSVCCOP)'=""
SET @FDA@(14)=ARSVCCOP
+126 if $GET(ARSVCCON)'=""
SET @FDA@(15)=+ARSVCCON
+127 if $GET(ARDAPTDT)'=""
SET @FDA@(22)=ARDAPTDT
+128 if $GET(ARNLT)'=""
SET @FDA@(47)=ARNLT
+129 DO FDAPRER(.FDA,ARPRER,"+1")
+130 if (+$GET(ARORDN)'=0)
SET @FDA@(46)=ARORDN
+131 SET @FDA@(23)="O"
+132 IF $GET(ARCOMM)'=""
Begin DoDot:2
+133 SET ARCOMM=$$CTRL^XMXUTIL1(ARCOMM)
+134 SET @FDA@(25)=ARCOMM
End DoDot:2
+135 if $GET(ARMAR)'=""
SET @FDA@(41)=ARMAR
+136 IF +ARMAR
IF $GET(ARMAI)'=""
SET @FDA@(42)=ARMAI
+137 IF +ARMAR
IF $GET(ARMAN)'=""
SET @FDA@(43)=ARMAN
+138 if $GET(INP(23))'=""
SET @FDA@(.02)=$SELECT(INP(23)="N":"N",INP(23)="NEW":"N",INP(23)="E":"E",INP(23)="ESTABLISHED":"E",1:"")
+139 IF $GET(ARPARENT)
Begin DoDot:2
+140 SET @FDA@(43.1)=$$MRTCHILDSEQUENCE($GET(ARPARENT),$GET(DFN))
End DoDot:2
+141 if +ARPARENT
SET @FDA@(43.8)=+ARPARENT
+142 ; initial PID change allowed field set to no.
+143 SET @FDA@(49)=0
End DoDot:1
+144 IF '$TEST
Begin DoDot:1
+145 SET ARIEN=ARIEN_","
+146 KILL ARDATA,ARERR
+147 DO GETS^DIQ(FNUM,ARIEN,"*","IE","ARDATA","ARERR")
+148 IF $DATA(ARERR)
MERGE ARMSG=ARERR
KILL FDA
QUIT
+149 SET FDA=$NAME(FDA(FNUM,ARIEN))
+150 IF $DATA(ARORIGDT)
Begin DoDot:2
+151 SET ARORIGDT=$PIECE(ARORIGDT,"@",1)
SET %DT=""
SET X=ARORIGDT
DO ^%DT
SET ARORIGDTI=Y
+152 IF ARORIGDTI'=ARDATA(FNUM,ARIEN,1,"I")
SET @FDA@(1)=$SELECT(ARORIGDT="":"@",1:ARORIGDT)
End DoDot:2
+153 IF $DATA(ARINST)
IF ARINST'=ARDATA(FNUM,ARIEN,2,"I")
SET @FDA@(2)=+ARINST
+154 IF $DATA(ARTYPE)
IF ARTYPE'=ARDATA(FNUM,ARIEN,4,"E")
SET @FDA@(4)=$SELECT(ARTYPE="APPOINTMENT":"APPT",ARTYPE="MOBILE":"MOBILE",1:ARTYPE)
+155 IF $GET(VAOSGUID)'=""
IF VAOSGUID'=ARDATA(FNUM,ARIEN,5,"I")
SET @FDA@(5)=VAOSGUID
+156 IF ARCLIN'=""
IF ARCLIN'=ARDATA(FNUM,ARIEN,8,"I")
SET @FDA@(8)=+ARCLIN
SET AUDF=1
if ARDATA(FNUM,ARIEN,8.5,"I")'=""
SET @FDA@(8.5)="@"
+157 IF ARSTOP'=""
IF ARSTOP'=ARDATA(FNUM,ARIEN,8.5,"I")
SET @FDA@(8.5)=+ARSTOP
SET AUDF=1
if ARDATA(FNUM,ARIEN,8,"I")'=""
SET @FDA@(8)="@"
+158 if +ARAPTYP
SET @FDA@(8.7)=+ARAPTYP
+159 IF $DATA(ARUSER)
IF ARUSER'=ARDATA(FNUM,ARIEN,9,"I")
SET @FDA@(9)=+ARUSER
+160 IF $DATA(AREDT)
IF AREDT'=$GET(ARDATA(FNUM,ARIEN,9.5,"I"))
SET @FDA@(9.5)=AREDT
+161 IF $DATA(ARPRIO)
IF ARPRIO'=ARDATA(FNUM,ARIEN,10,"I")
SET @FDA@(10)=$SELECT(ARPRIO="":"@",1:ARPRIO)
+162 IF $DATA(ARENPRI)
IF ARENPRI'=ARDATA(FNUM,ARIEN,10.5,"E")
SET @FDA@(10.5)=ARENPRI
+163 IF $DATA(ARREQBY)
IF ARREQBY'=ARDATA(FNUM,ARIEN,11,"I")
SET @FDA@(11)=$SELECT(ARREQBY="":"@",1:ARREQBY)
+164 IF $DATA(ARPROV)
IF ARPROV'=ARDATA(FNUM,ARIEN,12,"I")
SET @FDA@(12)=+ARPROV
+165 IF $DATA(ARSVCCOP)
IF ARSVCCOP'=$GET(ARDATA(FNUM,ARIEN,14,"I"))
SET @FDA@(14)=ARSVCCOP
+166 IF $DATA(ARSVCCON)
IF ARSVCCON'=ARDATA(FNUM,ARIEN,15,"E")
SET @FDA@(15)=+ARSVCCON
+167 IF $DATA(ARDAPTDT)
IF ARDAPTDT'=ARDATA(FNUM,ARIEN,22,"I")
SET @FDA@(22)=$SELECT(ARDAPTDT="":"@",1:ARDAPTDT)
+168 IF $DATA(ARCOMM)
IF ARCOMM'=ARDATA(FNUM,ARIEN,25,"I")
Begin DoDot:2
+169 SET LASTNOTE=ARDATA(FNUM,ARIEN,25,"I")
+170 SET ARCOMM=$$CTRL^XMXUTIL1(ARCOMM)
+171 SET @FDA@(25)=$SELECT(ARCOMM="":"@",1:ARCOMM)
End DoDot:2
+172 if $GET(ARMAR)'=""
SET @FDA@(41)=ARMAR
+173 if $GET(ARMAI)'=""
SET @FDA@(42)=ARMAI
+174 if $GET(ARMAN)'=""
SET @FDA@(43)=ARMAN
+175 if $GET(ARNLT)'=""
SET @FDA@(47)=ARNLT
+176 DO DELPRER(+ARIEN)
+177 DO FDAPRER(.FDA,ARPRER,+ARIEN)
+178 if +$GET(ARORDN)'=0
SET @FDA@(46)=ARORDN
+179 if $GET(INP(23))'=""
SET @FDA@(.02)=$SELECT(INP(23)="N":"N",INP(23)="NEW":"N",INP(23)="E":"E",INP(23)="ESTABLISHED":"E",1:"")
+180 if +ARPARENT
SET @FDA@(43.8)=+ARPARENT
End DoDot:1
+181 ; Only call UPDATE^DIE if there are any array entries in FDA
+182 if $DATA(FDA)>9
DO UPDATE^DIE("","FDA","ARRET","ARMSG")
+183 ; Add PID History entry for appt req
+184 SET AREQIEN=$SELECT($GET(ARIEN):ARIEN,1:$GET(ARRET(1)))
+185 ; 409.85 COMMENTS AUDIT multiple
+186 IF $LENGTH(ARCOMM)
IF $LENGTH(AREQIEN)
Begin DoDot:1
+187 NEW LASTLENGTH,NEWLENGTH,NEWNOTE
+188 SET NEWNOTE=ARCOMM
+189 IF $LENGTH(LASTNOTE)
Begin DoDot:2
+190 SET LASTLENGTH=$LENGTH(LASTNOTE)
SET NEWLENGTH=$LENGTH(ARCOMM)
+191 if NEWNOTE[LASTNOTE
SET NEWNOTE=$EXTRACT(ARCOMM,(LASTLENGTH+1),NEWLENGTH)
End DoDot:2
+192 if $EXTRACT(NEWNOTE,1,1)=" "
SET NEWNOTE=$EXTRACT(NEWNOTE,2,$LENGTH(NEWNOTE))
+193 NEW CAFDA
+194 SET CAFDA(409.8527,"+1,"_+AREQIEN_",",.01)=$$NOW^XLFDT
+195 SET CAFDA(409.8527,"+1,"_+AREQIEN_",",1)=$SELECT($GET(ARUSER):ARUSER,1:DUZ)
+196 SET CAFDA(409.8527,"+1,"_+AREQIEN_",",2)=NEWNOTE
+197 DO UPDATE^DIE("","CAFDA")
KILL CAFDA
End DoDot:1
+198 IF $GET(ARDAPTDT)
Begin DoDot:1
+199 SET ARRET=$GET(ARRET(1))
+200 IF $GET(ARIEN)
SET ARRET=ARIEN
SET ARRET=$TRANSLATE(ARRET,",","")
SET PIDCHECK=$$LASTPIDCHECK(ARRET,ARDAPTDT)
+201 IF $GET(PIDCHECK)=0
QUIT
+202 SET ARUSER=$$GET1^DIQ(200,ARUSER,.01,"E")
+203 SET FDA(409.854,"+1,"_ARRET_",",.01)=$$NOW^XLFDT
+204 SET FDA(409.854,"+1,"_ARRET_",",1)=ARDAPTDT
+205 SET FDA(409.854,"+1,"_ARRET_",",2)=ARUSER
+206 DO UPDATE^DIE(,"FDA","PIDHIEN","ERR")
KILL FDA
End DoDot:1
+207 IF $DATA(ARMSG)
Begin DoDot:1
+208 FOR MI=1:1:$GET(ARMSG("DIERR"))
SET RET=RET_"-1^"_$GET(ARMSG("DIERR",MI,"TEXT",1))_$CHAR(30)
+209 SET RET=RET_$CHAR(31)
End DoDot:1
+210 if $DATA(ARMSG)
QUIT
+211 SET ARINSTI=$PIECE($GET(^SDEC(409.85,$SELECT(+ARIEN:ARIEN,1:ARRET(1)),0)),U,3)
+212 IF $GET(INP(17))'=""
DO AR23(INP(17),$SELECT(+ARIEN:ARIEN,1:ARRET(1)))
+213 IF +ARMAR
IF $GET(INP(20))'=""
DO AR435(INP(20),$SELECT(+ARIEN:ARIEN,1:ARRET(1)))
+214 ;VS AUDIT
IF +AUDF
DO ARAUD($SELECT(+ARIEN:+ARIEN,1:ARRET(1)),ARCLIN,ARSTOP)
+215 IF $GET(INP(24))'=""
NEW SDI
FOR SDI=1:1:$LENGTH(INP(24),"|")
SET SDREC=$PIECE(INP(24),"|",SDI)
DO AR433($SELECT(+ARIEN:+ARIEN,1:ARRET(1)),SDREC)
+216 IF +ARPARENT
DO AR433(+ARPARENT,"~"_$SELECT(+ARIEN:+ARIEN,1:ARRET(1)))
+217 IF +$GET(ARRET(1))
SET RET=RET_ARRET(1)_U_$CHAR(30,31)
+218 IF '$TEST
SET RET=RET_+ARIEN_U_$CHAR(30,31)
+219 QUIT
+220 ;
LASTPIDCHECK(AREQIEN,ARDAPTDT) ; check PID HISTORY
+1 ; check if last PID in PID HISTORY mult is different from incoming PID
+2 NEW LASTPIDIEN,LASTPID
+3 SET LASTPIDIEN=$ORDER(^SDEC(409.85,AREQIEN,10,"A"),-1)
+4 SET LASTPID=$$GET1^DIQ(409.854,LASTPIDIEN_","_AREQIEN_",",1,"I")
+5 IF LASTPID=ARDAPTDT
QUIT 0
+6 QUIT 1
FDAPRER(FDA,ARPRER,ARIEN) ;
+1 NEW ASEQ,DELIM,PC,PR
+2 if $GET(ARPRER)=""
QUIT
+3 SET DELIM=";"
SET ASEQ=80
+4 FOR PC=1:1:$LENGTH(ARPRER,DELIM)
Begin DoDot:1
+5 SET PR=$PIECE(ARPRER,DELIM,PC)
if PR=""
QUIT
+6 SET ASEQ=ASEQ+1
SET FDA(409.8548,"+"_ASEQ_","_ARIEN_",",.01)=PR
End DoDot:1
+7 QUIT
DELPRER(ARIEN) ; clear mult field #48
+1 ;Delete all entries in PREREQUISITE mult (#48)
+2 NEW DIK,DA
+3 if $GET(ARIEN)'=+$GET(ARIEN)
QUIT
if ARIEN'>0
QUIT
+4 SET DIK="^SDEC(409.85,"_ARIEN_",8,"
SET DA(1)=ARIEN
+5 SET DA=0
FOR
SET DA=$ORDER(^SDEC(409.85,ARIEN,8,DA))
if DA'>0
QUIT
DO ^DIK
+6 QUIT
GETPRER(RET,ARIEN) ;
+1 NEW CC,PR
+2 IF $GET(^SDEC(409.85,+$GET(ARIEN),0))=""
SET RET="-1^Invalid SDEC APPT REQUEST id "_$GET(ARIEN)
QUIT
+3 SET RET=""
+4 SET CC=0
FOR
SET CC=$ORDER(^SDEC(409.85,ARIEN,8,CC))
if CC'>0
QUIT
Begin DoDot:1
+5 SET PR=$PIECE($GET(^SDEC(409.85,ARIEN,8,CC,0)),U,1)
if PR=""
QUIT
+6 SET RET=$SELECT(RET'="":RET_U_PR,1:PR)
End DoDot:1
+7 QUIT
ARAUD(ARIEN,ARCLIN,ARSTOP,DATE,USER) ;populate VS AUDIT mult (#45)
+1 NEW SDFDA,SDP,SDPN
+2 SET ARIEN=$GET(ARIEN)
if ARIEN=""
QUIT
+3 SET ARCLIN=$GET(ARCLIN)
+4 SET ARSTOP=$GET(ARSTOP)
+5 SET SDP=$ORDER(^SDEC(409.85,ARIEN,6,9999999),-1)
+6 IF +SDP
SET SDPN=^SDEC(409.85,ARIEN,6,SDP,0)
IF $PIECE(SDPN,U,3)=ARCLIN
IF $PIECE(SDPN,U,4)=ARSTOP
QUIT
+7 SET DATE=$GET(DATE)
if DATE=""
SET DATE=$EXTRACT($$NOW^XLFDT,1,12)
+8 SET USER=$GET(USER)
if USER=""
SET USER=DUZ
+9 SET SDFDA(409.8545,"+1,"_ARIEN_",",.01)=DATE
+10 SET SDFDA(409.8545,"+1,"_ARIEN_",",1)=USER
+11 if ARCLIN'=""
SET SDFDA(409.8545,"+1,"_ARIEN_",",2)=ARCLIN
+12 if ARSTOP'=""
SET SDFDA(409.8545,"+1,"_ARIEN_",",3)=ARSTOP
+13 DO UPDATE^DIE("","SDFDA")
+14 QUIT
AR433(ARIEN,SDEC) ;set MULT APPTS MADE
+1 ; ARIEN = (required) pointer to 409.85
+2 ; SDEC = (required) child pointers to 409.84 and 409.85 separated by pipe
+3 ; each pipe piece contains the following ~ pieces:
+4 ; 1. Appointment Id pointer to 409.84
+5 ; 2. Request Id pointer to 409.85
+6 NEW SDAPP,SDFDA,SDI,SDIEN
+7 SET ARIEN=$GET(ARIEN)
+8 if '$DATA(^SDEC(409.85,ARIEN,0))
QUIT
+9 SET SDEC=$GET(SDEC)
+10 FOR SDI=1:1:$LENGTH(SDEC,"|")
Begin DoDot:1
+11 KILL SDFDA
+12 SET SDAPP=$PIECE(SDEC,"|",SDI)
+13 IF $PIECE(SDAPP,"~",2)=""
IF $PIECE(SDAPP,"~",1)'=""
SET $PIECE(SDAPP,"~",2)=$PIECE($$GET1^DIQ(409.84,+SDAPP_",",.22,"I"),";",1)
+14 if $PIECE(SDAPP,"~",2)=""
QUIT
+15 SET SDIEN=$ORDER(^SDEC(409.85,ARIEN,2,"B",$PIECE(SDAPP,"~",2),0))
+16 SET SDIEN=$SELECT(SDIEN'="":SDIEN,1:"+1")
+17 IF $DATA(^SDEC(409.85,+$PIECE(SDAPP,"~",2),0))
SET SDFDA(409.852,SDIEN_","_ARIEN_",",.01)=+$PIECE(SDAPP,"~",2)
+18 IF $DATA(^SDEC(409.84,+$PIECE(SDAPP,"~",1),0))
SET SDFDA(409.852,SDIEN_","_ARIEN_",",.02)=+$PIECE(SDAPP,"~",1)
+19 if $DATA(SDFDA)
DO UPDATE^DIE("","SDFDA")
End DoDot:1
+20 QUIT
AR433D(SDEC) ;delete MULT APPTS MADE
+1 ;SDEC = (required) pointers to 409.84 separated by pipe
+2 NEW ARIEN,DFN,DIEN,SDAPP,SDFDA,SDI,SDJ,SDTYP,REOPEN,PARENREQ,PARSTAT
+3 SET SDEC=$GET(SDEC)
+4 FOR SDI=1:1:$LENGTH(SDEC,"|")
Begin DoDot:1
+5 SET SDAPP=$PIECE(SDEC,"|",SDI)
+6 if '$DATA(^SDEC(409.84,SDAPP,0))
QUIT
+7 SET REOPEN=$$GET1^DIQ(409.2,$$GET1^DIQ(409.84,SDAPP,.122,"I"),5,"I")
+8 SET DFN=$$GET1^DIQ(409.84,SDAPP_",",.05,"I")
+9 SET SDTYP=$$GET1^DIQ(409.84,SDAPP_",",.22,"I")
SET DIEN=$PIECE(SDTYP,";",1)
+10 IF $PIECE(SDTYP,";",2)="SDEC(409.85,"
SET ARIEN=""
FOR
SET ARIEN=$ORDER(^SDEC(409.85,"B",DFN,ARIEN))
if ARIEN=""
QUIT
Begin DoDot:2
+11 SET SDJ=""
FOR
SET SDJ=$ORDER(^SDEC(409.85,ARIEN,2,"B",DIEN,SDJ))
if SDJ=""
QUIT
Begin DoDot:3
+12 SET SDFDA(409.852,SDJ_","_ARIEN_",",.02)="@"
+13 DO UPDATE^DIE("","SDFDA")
KILL SDFDA
+14 SET PARENREQ=$$GET1^DIQ(409.85,DIEN,43.8,"I")
+15 SET PARSTAT=$$GET1^DIQ(409.85,PARENREQ,23,"I")
+16 IF PARSTAT="C"
IF REOPEN
Begin DoDot:4
+17 SET SDFDA(409.85,PARENREQ_",",19)=""
+18 SET SDFDA(409.85,PARENREQ_",",20)=""
+19 SET SDFDA(409.85,PARENREQ_",",21)=""
+20 SET SDFDA(409.85,PARENREQ_",",23)="O"
+21 DO FILE^DIE("","SDFDA","PARENTERR")
KILL SDFDA
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
AR438(ARIEN,SDPARENT,SDEC) ;set PARENT REQUEST (#43.8)
+1 NEW SDFDA
+2 IF $GET(SDPARENT)'=""
SET SDFDA(409.85,ARIEN_",",43.8)=SDPARENT
DO UPDATE^DIE("","SDFDA")
+3 QUIT
AR435(SDDT,ARIEN) ;
+1 ; ARIEN - Requested date ID pointer to 409.85
+2 ; SDDT - MRTC calculated preferred dates separated by pipe |:
+3 ; Each date can be in external format with no time.
+4 NEW SDI,SDJ,SDFDA,X,Y,%DT
+5 FOR SDI=1:1:$LENGTH(SDDT,"|")
Begin DoDot:1
+6 SET %DT=""
SET X=$PIECE($PIECE(SDDT,"|",SDI),"@",1)
DO ^%DT
SET SDJ=Y
+7 if SDJ=-1
QUIT
+8 ;don't add duplicates
if $ORDER(^SDEC(409.85,ARIEN,5,"B",SDJ,0))
QUIT
+9 SET SDFDA(409.851,"+1,"_ARIEN_",",.01)=SDJ
+10 DO UPDATE^DIE("","SDFDA")
End DoDot:1
+11 QUIT
WLACT(NAME) ;
+1 NEW ACTIVE,H
+2 SET ACTIVE=""
+3 SET H=""
FOR
SET H=$ORDER(^DIC(40.7,"B",NAME,H))
if H=""
QUIT
Begin DoDot:1
+4 IF $PIECE(^DIC(40.7,H,0),U,3)'=""
IF $PIECE(^DIC(40.7,H,0),U,3)<$$NOW^XLFDT()
QUIT
+5 SET ACTIVE=H
End DoDot:1
if ACTIVE'=""
QUIT
+6 QUIT ACTIVE
AR23(INP17,ARI) ;Patient Contacts
+1 NEW STR17,ARASD,ARASDH,ARDATA1,ARERR1,ARI1,ARIENS,ARIENS1,ARRET1,FDA
+2 NEW ARDT,ARUSR,X,Y,%DT
+3 SET ARIENS=ARI_","
+4 FOR ARI1=1:1:$LENGTH(INP17,"::")
Begin DoDot:1
+5 SET STR17=$PIECE(INP17,"::",ARI1)
+6 KILL FDA
+7 SET ARASD=$PIECE($PIECE(STR17,"~~",1),":",1,2)
SET ARASD=$$NETTOFM^SDECDATE(ARASD,"Y")
+8 IF (ARASD=-1)!(ARASD="")
QUIT
+9 SET ARDT=$PIECE($PIECE(STR17,"~~",1),":",1,2)
+10 SET ARASDH=""
+11 SET ARIENS1=$SELECT(ARASDH'="":ARASDH,1:"+1")_","_ARIENS
+12 SET FDA=$NAME(FDA(409.8544,ARIENS1))
+13 IF ARASDH'=""
Begin DoDot:2
+14 DO GETS^DIQ(409.8544,ARIENS1,"*","IE","ARDATA1","ARERR1")
+15 IF $PIECE(STR17,"~~",1)'=""
SET @FDA@(.01)=ARDT
+16 IF $PIECE(STR17,"~~",2)'=""
SET ARUSR=$PIECE(STR17,"~~",2)
SET @FDA@(2)=$SELECT(ARUSR="":"@",+ARUSR:$PIECE($GET(^VA(200,ARUSR,0)),U,1),1:ARUSER)
+17 IF $PIECE(STR17,"~~",4)'=""
SET @FDA@(3)=$PIECE(STR17,"~~",4)
+18 IF $PIECE(STR17,"~~",5)'=""
SET @FDA@(4)=$PIECE(STR17,"~~",5)
End DoDot:2
+19 IF ARASDH=""
Begin DoDot:2
+20 IF $PIECE(STR17,"~~",1)'=""
SET @FDA@(.01)=ARDT
+21 IF $PIECE(STR17,"~~",2)'=""
SET ARUSR=$PIECE(STR17,"~~",2)
SET @FDA@(2)=$SELECT(ARUSR="":"@",+ARUSR:$PIECE($GET(^VA(200,ARUSR,0)),U,1),1:ARUSR)
+22 IF $PIECE(STR17,"~~",4)'=""
SET @FDA@(3)=$PIECE(STR17,"~~",4)
+23 IF $PIECE(STR17,"~~",5)'=""
SET @FDA@(4)=$PIECE(STR17,"~~",5)
End DoDot:2
+24 if $DATA(@FDA)
DO UPDATE^DIE("E","FDA","ARRET1","ARMSG1")
End DoDot:1
+25 QUIT
UPDATE(ARIEN,APPDT,SDCL,SVCP,SVCPR,NOTE,SDAPPTYP,EAS) ;update 409.85 with appt info
+1 ; ARIEN = Appt Request pointer to 409.85
+2 ; APPDT = Appointment date/time (Scheduled Date of appt) in fm format
+3 ; SDCL = Clinic ID pointer to file 44
+4 ; SVCP = Service Connected % numeric 0-100
+5 ; SVCPR = Service Connected Priority 0:NO 1:YES
+6 ; NOTE = Comment only 1st 60 characters are used
+7 ; SDAPPTYP = (optional) Appointment type ID pointer to file 409.1
+8 ; EAS = (optional) Enterprise Appointment Scheduling Tracking Number associated to an appointment.
+9 ;all input must be verified by calling routine
+10 NEW SDDIV,SDFDA,SDSN,SDMSG
+11 if +$GET(SDAPPTYP)
SET SDFDA(409.85,ARIEN_",",8.7)=SDAPPTYP
+12 ;
SET SDFDA(409.85,ARIEN_",",13)=APPDT
+13 ;
SET SDFDA(409.85,ARIEN_",",13.1)=$PIECE($$NOW^XLFDT,".",1)
+14 ;
SET SDFDA(409.85,ARIEN_",",13.2)=SDCL
+15 ;
SET SDFDA(409.85,ARIEN_",",13.3)=$PIECE($GET(^SC(SDCL,0)),U,4)
+16 ;
SET SDFDA(409.85,ARIEN_",",13.4)=$PIECE($GET(^SC(SDCL,0)),U,7)
+17 SET SDDIV=$PIECE($GET(^SC(SDCL,0)),U,15)
+18 SET SDSN=$SELECT(SDDIV'="":$PIECE($GET(^DG(40.8,SDDIV,0)),U,2),1:"")
+19 ;
SET SDFDA(409.85,ARIEN_",",13.6)=SDSN
+20 ;
SET SDFDA(409.85,ARIEN_",",13.7)=DUZ
+21 ;
SET SDFDA(409.85,ARIEN_",",13.8)="R"
+22 ;
if SVCP'=""
SET SDFDA(409.85,ARIEN_",",14)=SVCP
+23 ;
if SVCPR'=""
SET SDFDA(409.85,ARIEN_",",15)=SVCPR
+24 if $GET(NOTE)'=""
SET SDFDA(409.85,ARIEN_",",25)=NOTE
+25 if $GET(EAS)'=""
SET SDFDA(409.85,ARIEN_",",100)=EAS
+26 DO UPDATE^DIE("","SDFDA","","SDMSG")
+27 QUIT
MRTCHILDSEQUENCE(PARENTREQUESTIEN,DFN) ; next child
+1 ; return next sequence number for child mrtc
+2 NEW COUNT,REQUESTIEN,IENS,NEXTSEQUENCENUM,CHILD,LASTCHILD
+3 SET REQUESTIEN=0
SET COUNT=0
SET LASTCHILD=""
+4 FOR
SET REQUESTIEN=$ORDER(^SDEC(409.85,"B",DFN,REQUESTIEN))
if 'REQUESTIEN
QUIT
Begin DoDot:1
+5 IF $$GET1^DIQ(409.85,REQUESTIEN,43.8,"I")=PARENTREQUESTIEN
Begin DoDot:2
+6 SET COUNT=COUNT+1
+7 SET CHILD(REQUESTIEN)=COUNT
End DoDot:2
End DoDot:1
+8 IF $DATA(CHILD)
Begin DoDot:1
+9 SET LASTCHILD=$ORDER(CHILD(LASTCHILD),-1)
+10 SET NEXTSEQUENCENUM=$GET(CHILD($GET(LASTCHILD)))+1
End DoDot:1
+11 IF '$DATA(CHILD)
SET NEXTSEQUENCENUM=1
+12 QUIT NEXTSEQUENCENUM
