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