SDHLAPT1 ;MS/PB - VISTA SCHEDULING RPCS ;Nov 14, 2014
;;5.3;Scheduling;**704**;Nov 14, 2018;Build 64
;
Q
;
ARSET(RET,INP) ;Appointment Request Set
;ARSET(RET,INP...) external parameter tag in SDEC
; 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 are:
; GROUP 1
; GROUP 2
; GROUP 3
; GROUP 4
; GROUP 5
; GROUP 6
; GROUP 7
; GROUP 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]
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,ARNLT,ARORDN
N FNUM,FDA,ARNEW,ARRET,ARMSG,ARDATA,ARERR,ARHOSN,AUDF,SDREC
N ARMAI,ARMAN,ARMAR,ARPARENT,ARPATTEL,ARENPRI,ARSTOP,ARSVCCON,ARSVCCOP
S (ARQUIT,AUDF)=0
S FNUM=$$FNUM^SDECAR
S RET=""
; 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="-1^Invalid Patient ID." Q
I '$D(^DPT(DFN,0)) S RET="-1^Invalid Patient ID" Q
S AREDT=$P($G(INP(3)),":",1,2)
S %DT="TX" S X=AREDT D ^%DT S AREDT=Y
I Y=-1 S RET="-1^Invalid Origination date." 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="-1^"_ARCLIN_" is an invalid Clinic ID." S ARQUIT=1 Q
..;S ARCLIN=$$GET1^DIQ(44,ARCLIN_",",.01)
.I '(+ARCLIN=ARCLIN) D
..S ARCLIN=$O(^SC("B",ARCLIN,0))
..I ARCLIN="" S RET="-1^"_ARCLIN_" is an invalid Clinic Name." 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 RET=RET_"-1^Invalid Desired Date." Q
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=""
;B "L+"
S ARSTOP=$G(INP(21))
I ARSTOP'="",ARCLIN'="" S RET="-1^Cannot include both Clinic and Service." 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 ARIEN=$G(ARIEN)
S ARNEW=ARIEN=""
I ARNEW D
. S AUDF=1
. S FDA=$NA(FDA(FNUM,"+1,"))
. S @FDA@(.01)=+DFN ;$S(+DFN:$P($G(^DPT(DFN,0)),U),1: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
. S:$G(ARTYPE)'="" @FDA@(4)=$S(ARTYPE="APPOINTMENT":"APPT",ARTYPE="MOBILE":"MOBILE",1:ARTYPE)
. 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)'="" @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:"")
. S:+ARPARENT @FDA@(43.8)=+ARPARENT
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 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)'="" @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")
I $D(ARMSG) D
. F MI=1:1:$G(ARMSG("DIERR")) S RET="-1^"_$G(ARMSG("DIERR",MI,"TEXT",1))
. ;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="1^"_ARRET(1)
E S RET="1^"_+ARIEN
Q
;
FDAPRER(FDA,ARPRER,ARIEN) ;Setup the FDA array for the PREREQUISITE multiple (#48)
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) ;Return the values in the PREREQUISITE multiple (#48)
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
; ARIEN - (required) pointer to SDEC APPT REQUEST file 409.85
; ARCLIN - (optional) pointer to HOSPITAL LOCATION file 44
; ARSTOP - (optional) pointer to CLINIC STOP file
; DATE - (optional) date/time in fileman format
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) ;set dates into MRTC CALC PREF DATES multiple field 43.5
;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
.S %DT="T" S X=$P($P(STR17,"~~",1),":",1,2) D ^%DT S ARASD=Y
.I (ARASD=-1)!(ARASD="") Q
.S ARDT=$P($P(STR17,"~~",1),":",1,2)
.S ARASDH="" ;$O(^SDEC(409.85,ARI,4,"B",ARASD,0))
.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 $P(STR17,"~~",6)'="" S @FDA@(5)=$E($P(STR17,"~~",6),1,160) ;COMMENT
.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
..;I $P(STR17,"~~",6)'="" S @FDA@(5)=$E($P(STR17,"~~",6),1,160) ;COMMENT
.D:$D(@FDA) UPDATE^DIE("E","FDA","ARRET1","ARMSG1")
Q
UPDATE(ARIEN,APPDT,SDCL,SVCP,SVCPR,NOTE,SDAPPTYP) ;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
;
;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 ;SCHEDULED DATEOF APPT = APPDT (SDECSTART)
S SDFDA(409.85,ARIEN_",",13.1)=$P($$NOW^XLFDT,".",1) ;DATE APPT. MADE= TODAY
S SDFDA(409.85,ARIEN_",",13.2)=SDCL ;APPT CLINIC= SDCL (SDECSCD)
S SDFDA(409.85,ARIEN_",",13.3)=$P($G(^SC(SDCL,0)),U,4) ;APPT INSTITUTION = Get from 44 using SDCL
S SDFDA(409.85,ARIEN_",",13.4)=$P($G(^SC(SDCL,0)),U,7) ;APPT STOP CODE= Get from 44 using SDCL
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 ;APPT STATION NMBER
S SDFDA(409.85,ARIEN_",",13.7)=DUZ ;APPT CLERK= Current User
S SDFDA(409.85,ARIEN_",",13.8)="R" ;APPT STATUS= R:Scheduled/Kept
S:SVCP'="" SDFDA(409.85,ARIEN_",",14)=SVCP ;SERVICE CONNECTED PERCENTAGE = SVCP (SDSVCP)
S:SVCPR'="" SDFDA(409.85,ARIEN_",",15)=SVCPR ;SERVICE CONNECTED PRIORITY = SVCPR (SDSVCPR)
S:$G(NOTE)'="" SDFDA(409.85,ARIEN_",",25)=NOTE
D UPDATE^DIE("","SDFDA","","SDMSG")
Q
GETAPP(DFN,SDECRES,STARTDT) ; returns the appointment id in 409.84
;.S SDECAPTID=$O(^SDEC(409.84,"ARSRC",SDECRES,STARTDT,""))
N APT,XX
S APT=0
S XX=0 F S XX=$O(^SDEC(409.84,"ARSRC",SDECRES,STARTDT,XX)) Q:XX="" D
.I $P(^SDEC(409.84,XX,0),"^",5)=DFN S APT=XX Q
Q APT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDHLAPT1 19300 printed Oct 16, 2024@18:58:29 Page 2
SDHLAPT1 ;MS/PB - VISTA SCHEDULING RPCS ;Nov 14, 2014
+1 ;;5.3;Scheduling;**704**;Nov 14, 2018;Build 64
+2 ;
+3 QUIT
+4 ;
ARSET(RET,INP) ;Appointment Request Set
+1 ;ARSET(RET,INP...) external parameter tag in SDEC
+2 ; INP(1) = (integer) Wait List IEN point to
+3 ; SDEC APPT REQUEST file 409.85.
+4 ; If null, a new entry will be added
+5 ; INP(2) = (text) DFN Pointer to the PATIENT file 2
+6 ; INP(3) = (date) Originating Date/time in external date form
+7 ; INP(4) = (text) Institution name NAME field from the INSTITUTION file
+8 ; INP(5) = (text) Request Type
+9 ; INP(6) = (text) REQ Specific Clinic name - NAME field in file 44
+10 ; INP(7) = (text) Originating User name - NAME field in NEW PERSON file 200
+11 ; INP(8) = (text) Priority - 'ASAP' or 'FUTURE'
+12 ; INP(9) = (text) Request By - 'PROVIDER' or 'PATIENT'
+13 ; INP(10) = (text) Provider name - NAME field in NEW PERSON file200
+14 ; INP(11) = (date) Desired Date of appointment in external format.
+15 ; INP(12) = (text) comment must be 1-60 characters
+16 ; INP(13) = (text) ENROLLMENT PRIORITY - Valid Values are:
+17 ; GROUP 1
+18 ; GROUP 2
+19 ; GROUP 3
+20 ; GROUP 4
+21 ; GROUP 5
+22 ; GROUP 6
+23 ; GROUP 7
+24 ; GROUP 8
+25 ; INP(14) = (text) MULTIPLE APPOINTMENT RTC NO; YES
+26 ; INP(15) = (integer) MULT APPT RTC INTERVAL integer between 1-365
+27 ; INP(16) = (integer) MULT APPT NUMBER integer between 1-100
+28 ; INP(17) = Patient Contacts separated by ::
+29 ; Each :: piece has the following ~~ pieces:
+30 ; 1) = (date) DATE ENTERED external date/time
+31 ; 2) = (text) PC ENTERED BY USER ID or NAME - Pointer toNEW PERSON file or NAME
+32 ; 4) = (optional) ACTION - valid values are:
+33 ; CALLED
+34 ; MESSAGE LEFT
+35 ; LETTER
+36 ; 5) = (optional) PATIENT PHONE Free-Text 4-20 characters
+37 ; 6) = NOT USED (optional) Comment 1-160 characters
+38 ; INP(18) = (optional) SERVICE CONNECTED PRIORITY valid values are NO YES
+39 ; INP(19) = (optional) SERVICE CONNECTED PERCENTAGE = numeric 0-100
+40 ; INP(20) = (optional) MRTC calculated preferred dates separated by pipe |:
+41 ; Each date can be in external format with no time.
+42 ; INP(21) = (optional) CLINIC STOP pointer to CLINIC STOP file 40.7
+43 ; used to populate the REQ SERVICE/SPECIALTY field in 409.85
+44 ; INP(22) = (optional) Appointment Type ID pointer to APPOINTMENT TYPE file 409.1
+45 ; INP(23) = (optional) Patient Status
+46 ; N = NEW
+47 ; E = ESTABLISHED
+48 ; INP(24) = (optional) MULT APPTS MADE
+49 ; list of child pointers to SDEC APPOINTMENT and/orSDEC APPT REQUEST files separated by pipe
+50 ; each pipe piece contains the following ~ pieces:
+51 ; 1. Appointment Id pointer to SDEC APPOINTMENT file 409.84
+52 ; 2. Request Id pointer to SDEC APPT REQUEST file 409.85
+53 ; INP(25) = (optional) PARENT REQUEST pointer to SDEC APPT REQUEST file 409.85
+54 ; INP(26) = (optional) NLT (No later than) [CPRS RTC REQUIREMENT]
+55 ; INP(27) = (optional) PREREQ (Prerequisites) [CPRS RTC REQUIREMENT]
+56 ; INP(28) = (optional) ORDER IEN [CPRS RTC REQUIREMENT]
+57 NEW X,Y,%DT
+58 NEW DFN,MI,ARAPTYP,ARIEN,ARORIGDT,ARORIGDTI,ARINST,ARINSTI,ARTYPE,ARTEAM,ARPOS,ARSRVSP,ARCLIN
+59 NEW ARUSER,ARPRIO,ARREQBY,ARPROV,ARDAPTDT,ARCOMM,AREESTAT,AREDT,ARQUIT,ARNLT,ARORDN
+60 NEW FNUM,FDA,ARNEW,ARRET,ARMSG,ARDATA,ARERR,ARHOSN,AUDF,SDREC
+61 NEW ARMAI,ARMAN,ARMAR,ARPARENT,ARPATTEL,ARENPRI,ARSTOP,ARSVCCON,ARSVCCOP
+62 SET (ARQUIT,AUDF)=0
+63 SET FNUM=$$FNUM^SDECAR
+64 SET RET=""
+65 ; Use MERGE instead of SET so we can know if values were actually specified or not.
+66 ; This way, if a value is null, we will delete any previous value,
+67 ; but if it is missing, then we will just ignore it.
+68 MERGE ARIEN=INP(1)
+69 SET DFN=$GET(INP(2))
+70 IF '+DFN
SET RET="-1^Invalid Patient ID."
QUIT
+71 IF '$DATA(^DPT(DFN,0))
SET RET="-1^Invalid Patient ID"
QUIT
+72 SET AREDT=$PIECE($GET(INP(3)),":",1,2)
+73 SET %DT="TX"
SET X=AREDT
DO ^%DT
SET AREDT=Y
+74 IF Y=-1
SET RET="-1^Invalid Origination date."
QUIT
+75 SET ARORIGDT=$PIECE(AREDT,".",1)
+76 SET ARINST=$GET(INP(4))
IF ARINST'=""
Begin DoDot:1
+77 IF '+ARINST
SET ARINST=$ORDER(^DIC(4,"B",ARINST,0))
End DoDot:1
+78 MERGE ARTYPE=INP(5)
+79 SET ARCLIN=$GET(INP(6))
+80 IF ARCLIN'=""
Begin DoDot:1
+81 IF +ARCLIN=ARCLIN
Begin DoDot:2
+82 IF '$DATA(^SC(+ARCLIN,0))
SET RET="-1^"_ARCLIN_" is an invalid Clinic ID."
SET ARQUIT=1
QUIT
+83 ;S ARCLIN=$$GET1^DIQ(44,ARCLIN_",",.01)
End DoDot:2
+84 IF '(+ARCLIN=ARCLIN)
Begin DoDot:2
+85 SET ARCLIN=$ORDER(^SC("B",ARCLIN,0))
+86 IF ARCLIN=""
SET RET="-1^"_ARCLIN_" is an invalid Clinic Name."
SET ARQUIT=1
QUIT
End DoDot:2
End DoDot:1
+87 if ARQUIT=1
QUIT
+88 SET ARUSER=$GET(INP(7))
+89 IF ARUSER'=""
IF '+ARUSER
SET ARUSER=$ORDER(^VA(200,"B",ARUSER,0))
+90 IF ARUSER=""
SET ARUSER=DUZ
+91 SET ARREQBY=$GET(INP(9))
IF ARREQBY'=""
Begin DoDot:1
+92 SET ARREQBY=$SELECT(ARREQBY="PATIENT":2,ARREQBY="PROVIDER":1,1:"")
End DoDot:1
+93 SET ARPROV=$GET(INP(10))
IF ARPROV'=""
IF '+ARPROV
SET ARPROV=$ORDER(^VA(200,"B",ARPROV,0))
+94 SET ARDAPTDT=INP(11)
+95 SET %DT=""
SET X=$PIECE($GET(ARDAPTDT),"@",1)
DO ^%DT
SET ARPRIO=$SELECT(Y=$PIECE($$NOW^XLFDT,".",1):"A",1:"F")
+96 SET ARDAPTDT=Y
+97 ;S RET=RET_"-1^Invalid Desired Date." Q
IF Y=-1
SET ARDAPTDT=""
+98 ;alb/sat 658
SET (INP(12),ARCOMM)=$TRANSLATE($GET(INP(12)),"^"," ")
+99 SET ARENPRI=$GET(INP(13))
Begin DoDot:1
+100 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
+101 SET ARMAR=$GET(INP(14))
IF ARMAR'=""
SET ARMAR=$SELECT(ARMAR="YES":1,1:0)
+102 MERGE ARMAI=INP(15)
+103 MERGE ARMAN=INP(16)
+104 SET ARSVCCON=$GET(INP(18))
if ARSVCCON'=""
SET ARSVCCON=$SELECT(ARSVCCON="YES":1,1:0)
+105 MERGE ARSVCCOP=INP(19)
IF $GET(ARSVCCOP)'=""
SET ARSVCCOP=+$GET(ARSVCCOP)
if (+ARSVCCOP<0)!(+ARSVCCOP>100)
SET ARSVCCOP=""
+106 ;B "L+"
+107 SET ARSTOP=$GET(INP(21))
+108 IF ARSTOP'=""
IF ARCLIN'=""
SET RET="-1^Cannot include both Clinic and Service."
QUIT
+109 SET ARAPTYP=+$GET(INP(22))
IF +ARAPTYP
IF '$DATA(^SD(409.1,ARAPTYP,0))
SET ARAPTYP=""
+110 SET ARPARENT=+$GET(INP(25))
IF +ARPARENT
IF '$DATA(^SDEC(409.85,+ARPARENT,0))
SET ARPARENT=""
+111 SET ARNLT=+$GET(INP(26))
+112 SET ARPRER=$GET(INP(27))
+113 SET ARORDN=+$GET(INP(28))
+114 ;CHECK FOR MISSING NLT,PREREQ,ORDER IEN ON MULTIPLE APPT REQUESTS
+115 IF +ARPARENT>0&(+$GET(INP(26))=0)
Begin DoDot:1
+116 SET ARNLT=$PIECE($GET(^SDEC(409.85,+ARPARENT,7)),U,2)
End DoDot:1
+117 IF +ARPARENT>0&($GET(INP(27))="")
Begin DoDot:1
+118 NEW PRIEN,PR
+119 SET PRIEN=0
FOR
SET PRIEN=$ORDER(^SDEC(409.85,+ARPARENT,8,PRIEN))
if PRIEN'>0
QUIT
Begin DoDot:2
+120 SET PR=$PIECE($GET(^SDEC(409.85,+ARPARENT,8,PRIEN,0)),"^")
if PR=""
QUIT
+121 SET ARPRER=$SELECT(ARPRER'="":ARPRER_";"_PR,1:PR)
End DoDot:2
End DoDot:1
+122 IF +ARPARENT>0&(+$GET(INP(28))=0)
Begin DoDot:1
+123 SET ARORDN=$PIECE($GET(^SDEC(409.85,+ARPARENT,7)),U,1)
End DoDot:1
+124 ;
+125 SET ARIEN=$GET(ARIEN)
+126 SET ARNEW=ARIEN=""
+127 IF ARNEW
Begin DoDot:1
+128 SET AUDF=1
+129 SET FDA=$NAME(FDA(FNUM,"+1,"))
+130 ;$S(+DFN:$P($G(^DPT(DFN,0)),U),1:DFN)
SET @FDA@(.01)=+DFN
+131 ;This handles the date/time coming in as "8/27/2014 12:00:00 AM"
+132 if $GET(ARORIGDT)'=""
SET @FDA@(1)=ARORIGDT
+133 if $GET(ARINST)'=""
SET @FDA@(2)=+ARINST
+134 if $GET(ARTYPE)'=""
SET @FDA@(4)=$SELECT(ARTYPE="APPOINTMENT":"APPT",ARTYPE="MOBILE":"MOBILE",1:ARTYPE)
+135 if $GET(ARCLIN)'=""
SET @FDA@(8)=+ARCLIN
+136 if $GET(ARSTOP)'=""
SET @FDA@(8.5)=+ARSTOP
+137 if +ARAPTYP
SET @FDA@(8.7)=+ARAPTYP
+138 if $GET(ARUSER)'=""
SET @FDA@(9)=+ARUSER
+139 if $GET(AREDT)'=""
SET @FDA@(9.5)=AREDT
+140 if $GET(ARPRIO)'=""
SET @FDA@(10)=ARPRIO
+141 if $GET(ARENPRI)'=""
SET @FDA@(10.5)=ARENPRI
+142 if $GET(ARREQBY)'=""
SET @FDA@(11)=ARREQBY
+143 if $GET(ARPROV)'=""
SET @FDA@(12)=+ARPROV
+144 if $GET(ARSVCCOP)'=""
SET @FDA@(14)=ARSVCCOP
+145 if $GET(ARSVCCON)'=""
SET @FDA@(15)=+ARSVCCON
+146 if $GET(ARDAPTDT)'=""
SET @FDA@(22)=ARDAPTDT
+147 if $GET(ARNLT)'=""
SET @FDA@(47)=ARNLT
+148 DO FDAPRER(.FDA,ARPRER,"+1")
+149 if $GET(ARORDN)'=""
SET @FDA@(46)=ARORDN
+150 SET @FDA@(23)="O"
+151 if $GET(ARCOMM)'=""
SET @FDA@(25)=ARCOMM
+152 if $GET(ARMAR)'=""
SET @FDA@(41)=ARMAR
+153 IF +ARMAR
IF $GET(ARMAI)'=""
SET @FDA@(42)=ARMAI
+154 IF +ARMAR
IF $GET(ARMAN)'=""
SET @FDA@(43)=ARMAN
+155 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:"")
+156 if +ARPARENT
SET @FDA@(43.8)=+ARPARENT
End DoDot:1
+157 IF '$TEST
Begin DoDot:1
+158 ; Append the comma for both
SET ARIEN=ARIEN_","
+159 KILL ARDATA,ARERR
+160 DO GETS^DIQ(FNUM,ARIEN,"*","IE","ARDATA","ARERR")
+161 IF $DATA(ARERR)
MERGE ARMSG=ARERR
KILL FDA
QUIT
+162 SET FDA=$NAME(FDA(FNUM,ARIEN))
+163 IF $DATA(ARORIGDT)
Begin DoDot:2
+164 SET ARORIGDT=$PIECE(ARORIGDT,"@",1)
SET %DT=""
SET X=ARORIGDT
DO ^%DT
SET ARORIGDTI=Y
+165 IF ARORIGDTI'=ARDATA(FNUM,ARIEN,1,"I")
SET @FDA@(1)=$SELECT(ARORIGDT="":"@",1:ARORIGDT)
End DoDot:2
+166 IF $DATA(ARINST)
IF ARINST'=ARDATA(FNUM,ARIEN,2,"I")
SET @FDA@(2)=+ARINST
+167 IF $DATA(ARTYPE)
IF ARTYPE'=ARDATA(FNUM,ARIEN,4,"E")
SET @FDA@(4)=$SELECT(ARTYPE="APPOINTMENT":"APPT",ARTYPE="MOBILE":"MOBILE",1:ARTYPE)
+168 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)="@"
+169 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)="@"
+170 if +ARAPTYP
SET @FDA@(8.7)=+ARAPTYP
+171 IF $DATA(ARUSER)
IF ARUSER'=ARDATA(FNUM,ARIEN,9,"I")
SET @FDA@(9)=+ARUSER
+172 IF $DATA(AREDT)
IF AREDT'=$GET(ARDATA(FNUM,ARIEN,9.5,"I"))
SET @FDA@(9.5)=AREDT
+173 IF $DATA(ARPRIO)
IF ARPRIO'=ARDATA(FNUM,ARIEN,10,"I")
SET @FDA@(10)=$SELECT(ARPRIO="":"@",1:ARPRIO)
+174 IF $DATA(ARENPRI)
IF ARENPRI'=ARDATA(FNUM,ARIEN,10.5,"E")
SET @FDA@(10.5)=ARENPRI
+175 IF $DATA(ARREQBY)
IF ARREQBY'=ARDATA(FNUM,ARIEN,11,"I")
SET @FDA@(11)=$SELECT(ARREQBY="":"@",1:ARREQBY)
+176 IF $DATA(ARPROV)
IF ARPROV'=ARDATA(FNUM,ARIEN,12,"I")
SET @FDA@(12)=+ARPROV
+177 IF $DATA(ARSVCCOP)
IF ARSVCCOP'=$GET(ARDATA(FNUM,ARIEN,14,"I"))
SET @FDA@(14)=ARSVCCOP
+178 IF $DATA(ARSVCCON)
IF ARSVCCON'=ARDATA(FNUM,ARIEN,15,"E")
SET @FDA@(15)=+ARSVCCON
+179 IF $DATA(ARDAPTDT)
IF ARDAPTDT'=ARDATA(FNUM,ARIEN,22,"I")
SET @FDA@(22)=$SELECT(ARDAPTDT="":"@",1:ARDAPTDT)
+180 IF $DATA(ARCOMM)
IF ARCOMM'=ARDATA(FNUM,ARIEN,25,"I")
SET @FDA@(25)=$SELECT(ARCOMM="":"@",1:ARCOMM)
+181 if $GET(ARMAR)'=""
SET @FDA@(41)=ARMAR
+182 if $GET(ARMAI)'=""
SET @FDA@(42)=ARMAI
+183 if $GET(ARMAN)'=""
SET @FDA@(43)=ARMAN
+184 if $GET(ARNLT)'=""
SET @FDA@(47)=ARNLT
+185 DO DELPRER(+ARIEN)
+186 DO FDAPRER(.FDA,ARPRER,+ARIEN)
+187 if $GET(ARORDN)'=""
SET @FDA@(46)=ARORDN
+188 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:"")
+189 if +ARPARENT
SET @FDA@(43.8)=+ARPARENT
End DoDot:1
+190 ; Only call UPDATE^DIE if there are any array entries in FDA
+191 if $DATA(FDA)>9
DO UPDATE^DIE("","FDA","ARRET","ARMSG")
+192 IF $DATA(ARMSG)
Begin DoDot:1
+193 FOR MI=1:1:$GET(ARMSG("DIERR"))
SET RET="-1^"_$GET(ARMSG("DIERR",MI,"TEXT",1))
+194 ;S RET=RET_$C(31)
End DoDot:1
+195 if $DATA(ARMSG)
QUIT
+196 SET ARINSTI=$PIECE($GET(^SDEC(409.85,$SELECT(+ARIEN:ARIEN,1:ARRET(1)),0)),U,3)
+197 ;I $G(INP(17))'="" D AR23(INP(17),$S(+ARIEN:ARIEN,1:ARRET(1))) ;patient contacts
+198 ;I +ARMAR,$G(INP(20))'="" D AR435(INP(20),$S(+ARIEN:ARIEN,1:ARRET(1))) ;MRTC CALC PREF DATES
+199 ;VS AUDIT
IF +AUDF
DO ARAUD($SELECT(+ARIEN:+ARIEN,1:ARRET(1)),ARCLIN,ARSTOP)
+200 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)
+201 IF +ARPARENT
DO AR433(+ARPARENT,"~"_$SELECT(+ARIEN:+ARIEN,1:ARRET(1)))
+202 IF +$GET(ARRET(1))
SET RET="1^"_ARRET(1)
+203 IF '$TEST
SET RET="1^"_+ARIEN
+204 QUIT
+205 ;
FDAPRER(FDA,ARPRER,ARIEN) ;Setup the FDA array for the PREREQUISITE multiple (#48)
+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) ;Return the values in the PREREQUISITE multiple (#48)
+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 ; ARIEN - (required) pointer to SDEC APPT REQUEST file 409.85
+2 ; ARCLIN - (optional) pointer to HOSPITAL LOCATION file 44
+3 ; ARSTOP - (optional) pointer to CLINIC STOP file
+4 ; DATE - (optional) date/time in fileman format
+5 NEW SDFDA,SDP,SDPN
+6 SET ARIEN=$GET(ARIEN)
if ARIEN=""
QUIT
+7 SET ARCLIN=$GET(ARCLIN)
+8 SET ARSTOP=$GET(ARSTOP)
+9 SET SDP=$ORDER(^SDEC(409.85,ARIEN,6,9999999),-1)
+10 IF +SDP
SET SDPN=^SDEC(409.85,ARIEN,6,SDP,0)
IF $PIECE(SDPN,U,3)=ARCLIN
IF $PIECE(SDPN,U,4)=ARSTOP
QUIT
+11 SET DATE=$GET(DATE)
if DATE=""
SET DATE=$EXTRACT($$NOW^XLFDT,1,12)
+12 SET USER=$GET(USER)
if USER=""
SET USER=DUZ
+13 SET SDFDA(409.8545,"+1,"_ARIEN_",",.01)=DATE
+14 SET SDFDA(409.8545,"+1,"_ARIEN_",",1)=USER
+15 if ARCLIN'=""
SET SDFDA(409.8545,"+1,"_ARIEN_",",2)=ARCLIN
+16 if ARSTOP'=""
SET SDFDA(409.8545,"+1,"_ARIEN_",",3)=ARSTOP
+17 DO UPDATE^DIE("","SDFDA")
+18 QUIT
+19 ;
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) ;set dates into MRTC CALC PREF DATES multiple field 43.5
+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 SET %DT="T"
SET X=$PIECE($PIECE(STR17,"~~",1),":",1,2)
DO ^%DT
SET ARASD=Y
+8 IF (ARASD=-1)!(ARASD="")
QUIT
+9 SET ARDT=$PIECE($PIECE(STR17,"~~",1),":",1,2)
+10 ;$O(^SDEC(409.85,ARI,4,"B",ARASD,0))
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 ;DATE ENTERED external date/time
IF $PIECE(STR17,"~~",1)'=""
SET @FDA@(.01)=ARDT
+16 ;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)
+17 ;ACTION C=Called; M=Message Left; L=LETTER
IF $PIECE(STR17,"~~",4)'=""
SET @FDA@(3)=$PIECE(STR17,"~~",4)
+18 ;PATIENT PHONE
IF $PIECE(STR17,"~~",5)'=""
SET @FDA@(4)=$PIECE(STR17,"~~",5)
+19 ;I $P(STR17,"~~",6)'="" S @FDA@(5)=$E($P(STR17,"~~",6),1,160) ;COMMENT
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)
+25 ;I $P(STR17,"~~",6)'="" S @FDA@(5)=$E($P(STR17,"~~",6),1,160) ;COMMENT
End DoDot:2
+26 if $DATA(@FDA)
DO UPDATE^DIE("E","FDA","ARRET1","ARMSG1")
End DoDot:1
+27 QUIT
UPDATE(ARIEN,APPDT,SDCL,SVCP,SVCPR,NOTE,SDAPPTYP) ;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 ;
+10 ;all input must be verified by calling routine
+11 NEW SDDIV,SDFDA,SDSN,SDMSG
+12 if +$GET(SDAPPTYP)
SET SDFDA(409.85,ARIEN_",",8.7)=SDAPPTYP
+13 ;SCHEDULED DATEOF APPT = APPDT (SDECSTART)
SET SDFDA(409.85,ARIEN_",",13)=APPDT
+14 ;DATE APPT. MADE= TODAY
SET SDFDA(409.85,ARIEN_",",13.1)=$PIECE($$NOW^XLFDT,".",1)
+15 ;APPT CLINIC= SDCL (SDECSCD)
SET SDFDA(409.85,ARIEN_",",13.2)=SDCL
+16 ;APPT INSTITUTION = Get from 44 using SDCL
SET SDFDA(409.85,ARIEN_",",13.3)=$PIECE($GET(^SC(SDCL,0)),U,4)
+17 ;APPT STOP CODE= Get from 44 using SDCL
SET SDFDA(409.85,ARIEN_",",13.4)=$PIECE($GET(^SC(SDCL,0)),U,7)
+18 SET SDDIV=$PIECE($GET(^SC(SDCL,0)),U,15)
+19 SET SDSN=$SELECT(SDDIV'="":$PIECE($GET(^DG(40.8,SDDIV,0)),U,2),1:"")
+20 ;APPT STATION NMBER
SET SDFDA(409.85,ARIEN_",",13.6)=SDSN
+21 ;APPT CLERK= Current User
SET SDFDA(409.85,ARIEN_",",13.7)=DUZ
+22 ;APPT STATUS= R:Scheduled/Kept
SET SDFDA(409.85,ARIEN_",",13.8)="R"
+23 ;SERVICE CONNECTED PERCENTAGE = SVCP (SDSVCP)
if SVCP'=""
SET SDFDA(409.85,ARIEN_",",14)=SVCP
+24 ;SERVICE CONNECTED PRIORITY = SVCPR (SDSVCPR)
if SVCPR'=""
SET SDFDA(409.85,ARIEN_",",15)=SVCPR
+25 if $GET(NOTE)'=""
SET SDFDA(409.85,ARIEN_",",25)=NOTE
+26 DO UPDATE^DIE("","SDFDA","","SDMSG")
+27 QUIT
GETAPP(DFN,SDECRES,STARTDT) ; returns the appointment id in 409.84
+1 ;.S SDECAPTID=$O(^SDEC(409.84,"ARSRC",SDECRES,STARTDT,""))
+2 NEW APT,XX
+3 SET APT=0
+4 SET XX=0
FOR
SET XX=$ORDER(^SDEC(409.84,"ARSRC",SDECRES,STARTDT,XX))
if XX=""
QUIT
Begin DoDot:1
+5 IF $PIECE(^SDEC(409.84,XX,0),"^",5)=DFN
SET APT=XX
QUIT
End DoDot:1
+6 QUIT APT
