SDESAPTREQSET ;ALB/TAW,KML,RRM,MGD - APPOINTMENT REQUEST CREATE / UPDATE ;July 19, 2022
;;5.3;Scheduling;**794,799,805,809,815,818,819,820**;Aug 13, 1993;Build 10
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
ARSET(RETURN,ARIEN,DFN,EDT,INST,TYPE,CLIN,USER,REQBY,PROV,DAPTDT,COMM,ENPRI,MAR,MAI,MAN,PATCONT,SVCCON,SVCCOP,MRTCPREFDT,STOP,APTYP,PATSTAT,MULTIAPTMADE,PARENT,NLT,PRER,ORDN,VAOSGUID,EAS,PCMT,INSTIEN,PATDATEPREFS,ARSTOPSEC,MODALITY) ;
;Refer SDESARSETDESC for the input param desc
;
N POP,SDAPTREQ,X,Y,ARORIGDT,ARORIGDTI,FNUM,INSTI,ARTEAM,ARPOS,ARSRVSP,MI,STOPIEN,EDIT,EDITPATCOM,DATERANGE1,DATERANGE2,DATERANGE3
N ARPRIO,AREESTAT,FDA,ARNEW,ARRET,ARMSG,ARDATA,ARERR,ARHOSN,AUDF,SDREC,ARPATTEL,DATE,RANGE,ARYIEN
D VALIDATE
I 'POP D
.I +ARIEN D UPDATE
.I +ARIEN=0 D CREATE
.I 'POP D FILE
D BUILDER
Q
VALIDATE ;
S (POP,AUDF)=0
S FNUM=$$FNUM^SDECAR
S ARIEN=$G(ARIEN,"")
I ARIEN S EDIT=1
;If the Update RPC is called and no ARIEN is sent then it will show as -1
I ARIEN'="" D
.I ARIEN=-1 S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,3) Q
.I '$D(^SDEC(409.85,ARIEN)) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,4)
S DFN=$G(DFN,"")
I ARIEN="" D
.I DFN="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,1)
.I DFN'="",'$D(^DPT(DFN,0)) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,2)
;Originating Dt/Tm
S EDT=$G(EDT,"")
I ARIEN="",EDT="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,48)
I EDT'="" S EDT=$$CALLDT(EDT) ; vse-2396
I EDT=-1 S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,49)
S ARORIGDT=$P(EDT,".",1)
;Institution IEN based on #99
S INSTIEN=$G(INSTIEN,"")
I INSTIEN'="" S INSTIEN=$$FIND1^DIC(4,"","X",INSTIEN,"D")
;Institution IEN based on #.01
S INST=$G(INST,"")
I INST'="" S INST=$$FIND1^DIC(4,"","X",INST,"B")
I 'INSTIEN,'INST S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,185)
;Appt Request Type
S TYPE=$G(TYPE,"")
S:TYPE="APPOINTMENT" TYPE="APPT"
I ARIEN="",TYPE="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,60)
;Clinic name/number
S CLIN=$G(CLIN,"")
I CLIN'="" D
.I +CLIN=CLIN D
..I '$D(^SC(+CLIN,0)) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,19)
.I +CLIN'=CLIN D
..S CLIN=$O(^SC("B",CLIN,0))
..I CLIN="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,51)
;User
S USER=$G(USER,"")
I USER'="",'+USER S USER=$O(^VA(200,"B",USER,0))
I USER="" S USER=DUZ
;Requested by
S REQBY=$G(REQBY,"")
I REQBY'="" D
.S REQBY=$S(REQBY="PATIENT":2,REQBY="PROVIDER":1,1:"")
I ARIEN="",REQBY="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,62)
;Provider name
S PROV=$G(PROV,"")
I PROV'="" S PROV=$O(^VA(200,"B",PROV,0))
;Desired date of appt
S DAPTDT=$G(DAPTDT,"")
S ARPRIO=""
I ARIEN="",DAPTDT="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,57)
I DAPTDT'="" D
.S DAPTDT=$$CALLDT(DAPTDT) ;vse-2396
.I DAPTDT=-1 S DAPTDT="",POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,58) Q
.I ARIEN="",DAPTDT<DT S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,59) Q ;Only validate on Create
.S ARPRIO=$S(DAPTDT=$P($$NOW^XLFDT,".",1):"A",1:"F") ;Priority ASAP or Future
;comment
S COMM=$TR($G(COMM),"^"," ")
;Enrollment Prio
S ENPRI=$G(ENPRI,"")
S:ENPRI'="" ENPRI=$S(ENPRI="GROUP 1":1,ENPRI="GROUP 2":2,ENPRI="GROUP3":3,ENPRI="GROUP4":4,ENPRI="GROUP 5":5,ENPRI="GROUP 6":6,ENPRI="GROUP 7":7,ENPRI="GROUP 8":8,1:ENPRI)
;MRTC Yes/No
S MAR=$G(MAR,"")
I MAR'="" S MAR=$S(MAR="YES":1,1:0)
;Multi Apt IEN
S MAI=$G(MAI,"")
;Multi Apt numbers
S MAN=$G(MAN,"")
;Serv Connect Prio
S SVCCON=$G(SVCCON,"")
S:SVCCON'="" SVCCON=$S(SVCCON="YES":1,1:0)
;Serv Connect %
S SVCCOP=$G(SVCCOP,"")
I SVCCOP'="" S:(+SVCCOP<0)!(+SVCCOP>100) SVCCOP=""
;Clinic Stop Code
S STOP=$G(STOP,"") ;
I $G(STOP) D
.S STOPIEN=0
.S STOPIEN=$O(^DIC(40.7,"C",STOP,STOPIEN))
.S STOP=STOPIEN
I ARIEN="",CLIN="",STOP="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,63)
I STOP'="",CLIN'="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,52,"Cannot include both Clinic Name and Clinic Stop.")
I CLIN="",STOP="",ARSTOPSEC="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,63)
I $G(ARSTOPSEC)'="" S ARSTOPSEC=$$FIND1^DIC(40.7,"","X",ARSTOPSEC,"C") I '$G(ARSTOPSEC) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,214)
I ARSTOPSEC'="",CLIN'="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,219)
;Appt Type#
S APTYP=+$G(APTYP,"")
I +APTYP,'$D(^SD(409.1,APTYP,0)) S APTYP=""
;Pat Status
S PATSTAT=$G(PATSTAT,"")
I PATSTAT'="" S PATSTAT=$S(PATSTAT="N":"N",PATSTAT="NEW":"N",PATSTAT="E":"E",PATSTAT="ESTABLISHED":"E",1:"")
;Parent Request
S PARENT=+$G(PARENT,"")
I +PARENT,'$D(^SDEC(409.85,+PARENT,0)) S PARENT=""
;No Later Than
S NLT=+$G(NLT,"")
I +PARENT>0&(+$G(NLT)=0) S NLT=$P($G(^SDEC(409.85,+PARENT,7)),"^",2)
;Prerequisite
S PRER=$G(PRER,"")
I +PARENT>0&(PRER="") D
.N PRIEN,PR
.S PRIEN=0 F S PRIEN=$O(^SDEC(409.85,+PARENT,8,PRIEN)) Q:PRIEN'>0 D
..S PR=$P($G(^SDEC(409.85,+PARENT,8,PRIEN,0)),"^")
..S:PR'="" PRER=$S(PRER'="":PRER_";"_PR,1:PR)
;Order IEN
S ORDN=+$G(ORDN)
I +PARENT>0&(+$G(ORDN)=0) S ORDN=$P($G(^SDEC(409.85,+PARENT,7)),"^",1)
;VAOS ID
S VAOSGUID=$G(VAOSGUID,"")
;EAS
S EAS=$TR($G(EAS),"^"," ")
I $L(EAS) S EAS=$$EASVALIDATE^SDESUTIL(EAS)
I EAS=-1 S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,142)
S PCMT=$TR($G(PCMT),"^"," ")
;preferred dates
I $D(PATDATEPREFS) D
.S ARYIEN=0
.F S ARYIEN=$O(PATDATEPREFS(ARYIEN)) Q:'ARYIEN D
..S DATE=$G(PATDATEPREFS(ARYIEN))
..S DATE=$$ISOTFM^SDAMUTDT($G(DATE),CLIN)
..I $G(DATE)=-1!($L(DATE,".")=1) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,46) Q
I $G(PATDATEPREFS(1)),'$G(PATDATEPREFS(2)) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,195)
I $G(PATDATEPREFS(3)),'$G(PATDATEPREFS(4)) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,195)
I $G(PATDATEPREFS(5)),'$G(PATDATEPREFS(6)) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,195)
I $G(MODALITY)'="",$$VALIDATEMODALITY^SDESINPUTVALUTL(.SDAPTREQ,MODALITY) S POP=1
Q
;
CREATE ;Build FDA array to add a new entry in 409.85
S AUDF=1
S FDA=$NA(FDA(FNUM,"+1,"))
S @FDA@(.01)=+DFN
S:$G(ARORIGDT)'="" @FDA@(1)=ARORIGDT
S:$G(INSTIEN)'="" @FDA@(2)=INSTIEN
S:$G(INSTIEN)=""&($G(INST)'="") @FDA@(2)=INST
S:$G(TYPE)'="" @FDA@(4)=TYPE
S:$G(VAOSGUID)'="" @FDA@(5)=VAOSGUID
S:$G(MODALITY)'="" @FDA@(6)=MODALITY
S:$G(CLIN)'="" @FDA@(8)=+CLIN
S:$G(STOP)'="" @FDA@(8.5)=+STOP
S:$G(ARSTOPSEC)'="" @FDA@(8.6)=+ARSTOPSEC
S:+APTYP @FDA@(8.7)=+APTYP
S:$G(USER)'="" @FDA@(9)=+USER
S:$G(EDT)'="" @FDA@(9.5)=EDT
S:$G(ARPRIO)'="" @FDA@(10)=ARPRIO
S:$G(ENPRI)'="" @FDA@(10.5)=ENPRI
S:$G(REQBY)'="" @FDA@(11)=REQBY
S:$G(PROV)'="" @FDA@(12)=+PROV
S:$G(DAPTDT)'="" @FDA@(13)=DAPTDT
S:$G(SVCCOP)'="" @FDA@(14)=SVCCOP
S:$G(SVCCON)'="" @FDA@(15)=+SVCCON
S:$G(DAPTDT)'="" @FDA@(22)=DAPTDT
S:$G(NLT)'="" @FDA@(47)=NLT
S:EAS'="" @FDA@(100)=EAS
D FDAPRER(.FDA,PRER,"+1")
S:$G(ORDN)'="" @FDA@(46)=ORDN
S @FDA@(23)="O"
S:$G(COMM)'="" @FDA@(25)=COMM
S:$G(MAR)'="" @FDA@(41)=MAR
I +MAR,$G(MAI)'="" S @FDA@(42)=MAI
I +MAR,$G(MAN)'="" S @FDA@(43)=MAN
S:PATSTAT'="" @FDA@(.02)=PATSTAT
S:+PARENT @FDA@(43.8)=+PARENT
I $G(PARENT) D
.S @FDA@(43.1)=$$MRTCHILDSEQUENCE^SDECAR2($G(PARENT),$G(DFN))
Q
;
UPDATE ;
S ARIEN=ARIEN_","
K ARDATA,ARERR
D GETS^DIQ(FNUM,ARIEN,"*","IE","ARDATA","ARERR")
I $D(ARERR) D Q
.S POP=1
.K FDA
.F MI=1:1:$G(ARERR("DIERR")) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,48,$G(ARERR("DIERR",MI,"TEXT",1)))
S FDA=$NA(FDA(FNUM,ARIEN))
I ARORIGDT'="" D
.S ARORIGDT=$P(ARORIGDT,"@",1) S ARORIGDTI=$$CALLDT(ARORIGDT)
.I ARORIGDTI'=ARDATA(FNUM,ARIEN,1,"I") S @FDA@(1)=$S(ARORIGDT="":"@",1:ARORIGDT)
I INSTIEN'="",INSTIEN'=ARDATA(FNUM,ARIEN,2,"I") S @FDA@(2)=INSTIEN
I INSTIEN="",INST'="" S @FDA@(2)=INST
I TYPE'="",TYPE'=ARDATA(FNUM,ARIEN,4,"I") S @FDA@(4)=TYPE
I VAOSGUID'="",VAOSGUID'=ARDATA(FNUM,ARIEN,5,"I") S @FDA@(5)=VAOSGUID
I MODALITY'="",MODALITY'=ARDATA(FNUM,ARIEN,6,"I") S @FDA@(6)=MODALITY
I CLIN'="",CLIN'=ARDATA(FNUM,ARIEN,8,"I") S @FDA@(8)=+CLIN,AUDF=1 D
.I ARDATA(FNUM,ARIEN,8.5,"I")'="" S @FDA@(8.5)="@",@FDA@(8.6)="@"
I STOP'="",STOP'=ARDATA(FNUM,ARIEN,8.5,"I") S @FDA@(8.5)=+STOP,AUDF=1 S:ARDATA(FNUM,ARIEN,8,"I")'="" @FDA@(8)="@"
I ARSTOPSEC'="",ARSTOPSEC'=ARDATA(FNUM,ARIEN,8.6,"I") S @FDA@(8.6)=+ARSTOPSEC,AUDF=1 S:ARDATA(FNUM,ARIEN,8,"I")'="" @FDA@(8)="@"
S:+APTYP @FDA@(8.7)=+APTYP
I USER'="",USER'=ARDATA(FNUM,ARIEN,9,"I") S @FDA@(9)=+USER
I EDT'="",EDT'=$G(ARDATA(FNUM,ARIEN,9.5,"I")) S @FDA@(9.5)=EDT
I ARPRIO'="",ARPRIO'=ARDATA(FNUM,ARIEN,10,"I") S @FDA@(10)=$S(ARPRIO="":"@",1:ARPRIO)
I ENPRI'="",ENPRI'=ARDATA(FNUM,ARIEN,10.5,"I") S @FDA@(10.5)=ENPRI
I REQBY'="",REQBY'=ARDATA(FNUM,ARIEN,11,"I") S @FDA@(11)=$S(REQBY="":"@",1:REQBY)
I PROV'="",PROV'=ARDATA(FNUM,ARIEN,12,"I") S @FDA@(12)=+PROV
I SVCCOP'="",SVCCOP'=$G(ARDATA(FNUM,ARIEN,14,"I")) S @FDA@(14)=SVCCOP
I SVCCON'="",SVCCON'=ARDATA(FNUM,ARIEN,15,"I") S @FDA@(15)=+SVCCON
I DAPTDT'="",DAPTDT'=ARDATA(FNUM,ARIEN,22,"I") S @FDA@(22)=$S(DAPTDT="":"@",1:DAPTDT)
I COMM'="",COMM'=ARDATA(FNUM,ARIEN,25,"I") S @FDA@(25)=$S(COMM="":"@",1:COMM)
S:MAR'="" @FDA@(41)=MAR
S:MAI'="" @FDA@(42)=MAI
S:MAN'="" @FDA@(43)=MAN
S:NLT'="" @FDA@(47)=NLT
S:EAS'="" @FDA@(100)=EAS
D DELPRER(+ARIEN)
D FDAPRER(.FDA,PRER,+ARIEN)
S:ORDN'="" @FDA@(46)=ORDN
S:PATSTAT'="" @FDA@(.02)=PATSTAT
S:+PARENT @FDA@(43.8)=+PARENT
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
;
FDAPRER(FDA,PRER,ARIEN) ;Setup the FDA array for the PREREQUISITE mult (#48)
N ASEQ,DELIM,PC,PR
Q:$G(PRER)=""
S DELIM=";",ASEQ=80
F PC=1:1:$L(PRER,DELIM) D
.S PR=$P(PRER,DELIM,PC) Q:PR=""
.S ASEQ=ASEQ+1,FDA(409.8548,"+"_ASEQ_","_ARIEN_",",.01)=PR
Q
;
FILE ;Perform file update
;Only call UPDATE^DIE if there are entries in FDA
D:$D(FDA)>9 UPDATE^DIE("","FDA","ARRET","ARMSG")
I $D(ARMSG) D Q
. F MI=1:1:$G(ARMSG("DIERR")) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,48,$G(ARMSG("DIERR",MI,"TEXT",1)))
N IEN
S IEN=$S(+ARIEN:+ARIEN,1:ARRET(1))
S INSTI=$P($G(^SDEC(409.85,IEN,0)),U,3)
I $G(PATCONT)'="" D AR23(PATCONT,IEN) ;Pat contacts
I +MAR,$G(MRTCPREFDT)'="" D AR435(MRTCPREFDT,IEN) ;MRTC CALC PREF DATES
I +AUDF D ARAUD(IEN,CLIN,STOP) ;VS AUDIT
I $G(MULTIAPTMADE)'="" D
.N SDI
.F SDI=1:1:$L(MULTIAPTMADE,"|") S SDREC=$P(MULTIAPTMADE,"|",SDI) D AR433(IEN,SDREC)
I +PARENT D AR433(+PARENT,"~"_IEN)
;file Pat entered comments if any sent
I PCMT]"",PCMT'["Patient preferred date range" D ARPCMT(IEN,PCMT)
;file Pat date preferences in comments mult
I $D(PATDATEPREFS(1)),$D(PATDATEPREFS(2)),'$G(EDIT) D
.S PATDATEPREFS(1)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(1),CLIN),PATDATEPREFS(1)=$$FMTE^XLFDT(PATDATEPREFS(1))
.S PATDATEPREFS(2)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(2),CLIN),PATDATEPREFS(2)=$$FMTE^XLFDT(PATDATEPREFS(2))
.S RANGE(1)="Patient preferred date range #1: "_PATDATEPREFS(1)_" to "_PATDATEPREFS(2)
.I $D(PATDATEPREFS(3)),$D(PATDATEPREFS(4)) D
..S PATDATEPREFS(3)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(3),CLIN),PATDATEPREFS(3)=$$FMTE^XLFDT(PATDATEPREFS(3))
..S PATDATEPREFS(4)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(4),CLIN),PATDATEPREFS(4)=$$FMTE^XLFDT(PATDATEPREFS(4))
..S RANGE(2)="Patient preferred date range #2: "_PATDATEPREFS(3)_" to "_PATDATEPREFS(4)
.I $D(PATDATEPREFS(5)),$D(PATDATEPREFS(6)) D
..S PATDATEPREFS(5)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(5),CLIN),PATDATEPREFS(5)=$$FMTE^XLFDT(PATDATEPREFS(5))
..S PATDATEPREFS(6)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(6),CLIN),PATDATEPREFS(6)=$$FMTE^XLFDT(PATDATEPREFS(6))
..S RANGE(3)="Patient preferred date range #3: "_PATDATEPREFS(5)_" to "_PATDATEPREFS(6)
.D WP^DIE(409.85,IEN_",",60,"A","RANGE")
I $G(EDIT) D
.I PCMT'["Patient preferred date range" S EDITPATCOM(1)=PCMT D WP^DIE(409.85,IEN_",",60,"","EDITPATCOM") Q
.S EDITPATCOM(1)=$P($G(PCMT),"Patient preferred date range",1)
.S DATERANGE1=$P($G(PCMT),"Patient preferred date range",2) I $L($G(DATERANGE1)) S EDITPATCOM(2)="Patient preferred date range"_$P($G(PCMT),"Patient preferred date range",2)
.S DATERANGE2=$P($G(PCMT),"Patient preferred date range",3) I $L($G(DATERANGE2)) S EDITPATCOM(3)="Patient preferred date range"_$P($G(PCMT),"Patient preferred date range",3)
.S DATERANGE3=$P($G(PCMT),"Patient preferred date range",4) I $L($G(DATERANGE3)) S EDITPATCOM(4)="Patient preferred date range"_$P($G(PCMT),"Patient preferred date range",4)
.D WP^DIE(409.85,IEN_",",60,"","EDITPATCOM")
I +$G(ARRET(1)) S SDAPTREQ("AptReqCreate","IEN")=IEN
E S SDAPTREQ("AptReqUpdate","IEN")=IEN
Q
;
ARPCMT(ARIEN,COMMENTSFLD60) ;populate word processing PATIENT COMMENTS (409.855,60)
;ARIEN-(req)IEN to entry in 409.85
;COMMENTSFLD60-(opt)VAOS related patient-entered comments
N SDFDA,PCMTSARRAY
S COMMENTSFLD60=$G(COMMENTSFLD60)
D WP^SDECUTL(.PCMTSARRAY,COMMENTSFLD60)
D WP^DIE(409.85,ARIEN_",",60,"","PCMTSARRAY")
Q
;
ARAUD(ARIEN,CLIN,STOP,DATE,USER) ;populate VS AUDIT mult field 45
;ARIEN-(req)pointer to SDEC APPT REQUEST file 409.85
;CLIN-(opt)pointer to HOSPITAL LOCATION file 44
;STOP-(opt)pointer to CLINIC STOP file
;DATE-(opt)dt/tm in FileMan format
N SDFDA,SDP,SDPN,ERRARRY
S ARIEN=$G(ARIEN) Q:ARIEN=""
S CLIN=$G(CLIN)
S STOP=$G(STOP)
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)=CLIN,$P(SDPN,U,4)=STOP 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:CLIN'="" SDFDA(409.8545,"+1,"_ARIEN_",",2)=CLIN
S:STOP'="" SDFDA(409.8545,"+1,"_ARIEN_",",3)=STOP
D UPDATE^DIE("","SDFDA",,"ERRARRY")
Q
;
AR433(ARIEN,SDEC) ;set MULT APPTS MADE
;INPUT:
; ARIEN=(req)pointer to SDEC APPT REQUEST file 409.85
;
;
N SDAPP,SDFDA,SDI,SDIEN,ERRARRY
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",,"ERRARRY")
Q
;
AR435(SDDT,ARIEN) ;set dates into MRTC CALC PREF DATES mult 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,TMPDT,ERRARRY
F SDI=1:1:$L(SDDT,"|") D
.S TMPDT=$P($P(SDDT,"|",SDI),"@",1)
.S SDJ=$$CALLDT(TMPDT)
.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",,"ERRARRY")
Q
;
AR23(INP17,ARI) ;Pat Contacts
N STR17,ARASDH,ARDATA1,ARERR1,ARI1,ARIENS,ARIENS1,ARRET1,FDA,ARMSG1
N ARDT,ARUSR
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 ARDT=$P($P(STR17,"~~",1),":",1,2)
.S ARDT=$$CALLDT(ARDT)
.I (ARDT=-1)!(ARDT="") Q
.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 dt/tm
..I $P(STR17,"~~",2)'="" S ARUSR=$P(STR17,"~~",2) S @FDA@(2)=$S(ARUSR="":"@",+ARUSR:$P($G(^VA(200,ARUSR,0)),U,1),1:USER) ;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 dt/tme
..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",,"ARMSG1")
Q
CALLDT(X) ;
Q $$ISOTFM^SDAMUTDT(X) ;VSE-2396
;
BUILDER ;Convert data to JSON
N JSONERR
S JSONERR=""
D ENCODE^SDESJSON(.SDAPTREQ,.RETURN,.JSONERR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDESAPTREQSET 16575 printed Nov 22, 2024@18:05:38 Page 2
SDESAPTREQSET ;ALB/TAW,KML,RRM,MGD - APPOINTMENT REQUEST CREATE / UPDATE ;July 19, 2022
+1 ;;5.3;Scheduling;**794,799,805,809,815,818,819,820**;Aug 13, 1993;Build 10
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
ARSET(RETURN,ARIEN,DFN,EDT,INST,TYPE,CLIN,USER,REQBY,PROV,DAPTDT,COMM,ENPRI,MAR,MAI,MAN,PATCONT,SVCCON,SVCCOP,MRTCPREFDT,STOP,APTYP,PATSTAT,MULTIAPTMADE,PARENT,NLT,PRER,ORDN,VAOSGUID,EAS,PCMT,INSTIEN,PATDATEPREFS,ARSTOPSEC,MODALITY) ;
+1 ;Refer SDESARSETDESC for the input param desc
+2 ;
+3 NEW POP,SDAPTREQ,X,Y,ARORIGDT,ARORIGDTI,FNUM,INSTI,ARTEAM,ARPOS,ARSRVSP,MI,STOPIEN,EDIT,EDITPATCOM,DATERANGE1,DATERANGE2,DATERANGE3
+4 NEW ARPRIO,AREESTAT,FDA,ARNEW,ARRET,ARMSG,ARDATA,ARERR,ARHOSN,AUDF,SDREC,ARPATTEL,DATE,RANGE,ARYIEN
+5 DO VALIDATE
+6 IF 'POP
Begin DoDot:1
+7 IF +ARIEN
DO UPDATE
+8 IF +ARIEN=0
DO CREATE
+9 IF 'POP
DO FILE
End DoDot:1
+10 DO BUILDER
+11 QUIT
VALIDATE ;
+1 SET (POP,AUDF)=0
+2 SET FNUM=$$FNUM^SDECAR
+3 SET ARIEN=$GET(ARIEN,"")
+4 IF ARIEN
SET EDIT=1
+5 ;If the Update RPC is called and no ARIEN is sent then it will show as -1
+6 IF ARIEN'=""
Begin DoDot:1
+7 IF ARIEN=-1
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,3)
QUIT
+8 IF '$DATA(^SDEC(409.85,ARIEN))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,4)
End DoDot:1
+9 SET DFN=$GET(DFN,"")
+10 IF ARIEN=""
Begin DoDot:1
+11 IF DFN=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,1)
+12 IF DFN'=""
IF '$DATA(^DPT(DFN,0))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,2)
End DoDot:1
+13 ;Originating Dt/Tm
+14 SET EDT=$GET(EDT,"")
+15 IF ARIEN=""
IF EDT=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,48)
+16 ; vse-2396
IF EDT'=""
SET EDT=$$CALLDT(EDT)
+17 IF EDT=-1
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,49)
+18 SET ARORIGDT=$PIECE(EDT,".",1)
+19 ;Institution IEN based on #99
+20 SET INSTIEN=$GET(INSTIEN,"")
+21 IF INSTIEN'=""
SET INSTIEN=$$FIND1^DIC(4,"","X",INSTIEN,"D")
+22 ;Institution IEN based on #.01
+23 SET INST=$GET(INST,"")
+24 IF INST'=""
SET INST=$$FIND1^DIC(4,"","X",INST,"B")
+25 IF 'INSTIEN
IF 'INST
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,185)
+26 ;Appt Request Type
+27 SET TYPE=$GET(TYPE,"")
+28 if TYPE="APPOINTMENT"
SET TYPE="APPT"
+29 IF ARIEN=""
IF TYPE=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,60)
+30 ;Clinic name/number
+31 SET CLIN=$GET(CLIN,"")
+32 IF CLIN'=""
Begin DoDot:1
+33 IF +CLIN=CLIN
Begin DoDot:2
+34 IF '$DATA(^SC(+CLIN,0))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,19)
End DoDot:2
+35 IF +CLIN'=CLIN
Begin DoDot:2
+36 SET CLIN=$ORDER(^SC("B",CLIN,0))
+37 IF CLIN=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,51)
End DoDot:2
End DoDot:1
+38 ;User
+39 SET USER=$GET(USER,"")
+40 IF USER'=""
IF '+USER
SET USER=$ORDER(^VA(200,"B",USER,0))
+41 IF USER=""
SET USER=DUZ
+42 ;Requested by
+43 SET REQBY=$GET(REQBY,"")
+44 IF REQBY'=""
Begin DoDot:1
+45 SET REQBY=$SELECT(REQBY="PATIENT":2,REQBY="PROVIDER":1,1:"")
End DoDot:1
+46 IF ARIEN=""
IF REQBY=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,62)
+47 ;Provider name
+48 SET PROV=$GET(PROV,"")
+49 IF PROV'=""
SET PROV=$ORDER(^VA(200,"B",PROV,0))
+50 ;Desired date of appt
+51 SET DAPTDT=$GET(DAPTDT,"")
+52 SET ARPRIO=""
+53 IF ARIEN=""
IF DAPTDT=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,57)
+54 IF DAPTDT'=""
Begin DoDot:1
+55 ;vse-2396
SET DAPTDT=$$CALLDT(DAPTDT)
+56 IF DAPTDT=-1
SET DAPTDT=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,58)
QUIT
+57 ;Only validate on Create
IF ARIEN=""
IF DAPTDT<DT
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,59)
QUIT
+58 ;Priority ASAP or Future
SET ARPRIO=$SELECT(DAPTDT=$PIECE($$NOW^XLFDT,".",1):"A",1:"F")
End DoDot:1
+59 ;comment
+60 SET COMM=$TRANSLATE($GET(COMM),"^"," ")
+61 ;Enrollment Prio
+62 SET ENPRI=$GET(ENPRI,"")
+63 if ENPRI'=""
SET ENPRI=$SELECT(ENPRI="GROUP 1":1,ENPRI="GROUP 2":2,ENPRI="GROUP3":3,ENPRI="GROUP4":4,ENPRI="GROUP 5":5,ENPRI="GROUP 6":6,ENPRI="GROUP 7":7,ENPRI="GROUP 8":8,1:ENPRI)
+64 ;MRTC Yes/No
+65 SET MAR=$GET(MAR,"")
+66 IF MAR'=""
SET MAR=$SELECT(MAR="YES":1,1:0)
+67 ;Multi Apt IEN
+68 SET MAI=$GET(MAI,"")
+69 ;Multi Apt numbers
+70 SET MAN=$GET(MAN,"")
+71 ;Serv Connect Prio
+72 SET SVCCON=$GET(SVCCON,"")
+73 if SVCCON'=""
SET SVCCON=$SELECT(SVCCON="YES":1,1:0)
+74 ;Serv Connect %
+75 SET SVCCOP=$GET(SVCCOP,"")
+76 IF SVCCOP'=""
if (+SVCCOP<0)!(+SVCCOP>100)
SET SVCCOP=""
+77 ;Clinic Stop Code
+78 ;
SET STOP=$GET(STOP,"")
+79 IF $GET(STOP)
Begin DoDot:1
+80 SET STOPIEN=0
+81 SET STOPIEN=$ORDER(^DIC(40.7,"C",STOP,STOPIEN))
+82 SET STOP=STOPIEN
End DoDot:1
+83 IF ARIEN=""
IF CLIN=""
IF STOP=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,63)
+84 IF STOP'=""
IF CLIN'=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,52,"Cannot include both Clinic Name and Clinic Stop.")
+85 IF CLIN=""
IF STOP=""
IF ARSTOPSEC=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,63)
+86 IF $GET(ARSTOPSEC)'=""
SET ARSTOPSEC=$$FIND1^DIC(40.7,"","X",ARSTOPSEC,"C")
IF '$GET(ARSTOPSEC)
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,214)
+87 IF ARSTOPSEC'=""
IF CLIN'=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,219)
+88 ;Appt Type#
+89 SET APTYP=+$GET(APTYP,"")
+90 IF +APTYP
IF '$DATA(^SD(409.1,APTYP,0))
SET APTYP=""
+91 ;Pat Status
+92 SET PATSTAT=$GET(PATSTAT,"")
+93 IF PATSTAT'=""
SET PATSTAT=$SELECT(PATSTAT="N":"N",PATSTAT="NEW":"N",PATSTAT="E":"E",PATSTAT="ESTABLISHED":"E",1:"")
+94 ;Parent Request
+95 SET PARENT=+$GET(PARENT,"")
+96 IF +PARENT
IF '$DATA(^SDEC(409.85,+PARENT,0))
SET PARENT=""
+97 ;No Later Than
+98 SET NLT=+$GET(NLT,"")
+99 IF +PARENT>0&(+$GET(NLT)=0)
SET NLT=$PIECE($GET(^SDEC(409.85,+PARENT,7)),"^",2)
+100 ;Prerequisite
+101 SET PRER=$GET(PRER,"")
+102 IF +PARENT>0&(PRER="")
Begin DoDot:1
+103 NEW PRIEN,PR
+104 SET PRIEN=0
FOR
SET PRIEN=$ORDER(^SDEC(409.85,+PARENT,8,PRIEN))
if PRIEN'>0
QUIT
Begin DoDot:2
+105 SET PR=$PIECE($GET(^SDEC(409.85,+PARENT,8,PRIEN,0)),"^")
+106 if PR'=""
SET PRER=$SELECT(PRER'="":PRER_";"_PR,1:PR)
End DoDot:2
End DoDot:1
+107 ;Order IEN
+108 SET ORDN=+$GET(ORDN)
+109 IF +PARENT>0&(+$GET(ORDN)=0)
SET ORDN=$PIECE($GET(^SDEC(409.85,+PARENT,7)),"^",1)
+110 ;VAOS ID
+111 SET VAOSGUID=$GET(VAOSGUID,"")
+112 ;EAS
+113 SET EAS=$TRANSLATE($GET(EAS),"^"," ")
+114 IF $LENGTH(EAS)
SET EAS=$$EASVALIDATE^SDESUTIL(EAS)
+115 IF EAS=-1
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,142)
+116 SET PCMT=$TRANSLATE($GET(PCMT),"^"," ")
+117 ;preferred dates
+118 IF $DATA(PATDATEPREFS)
Begin DoDot:1
+119 SET ARYIEN=0
+120 FOR
SET ARYIEN=$ORDER(PATDATEPREFS(ARYIEN))
if 'ARYIEN
QUIT
Begin DoDot:2
+121 SET DATE=$GET(PATDATEPREFS(ARYIEN))
+122 SET DATE=$$ISOTFM^SDAMUTDT($GET(DATE),CLIN)
+123 IF $GET(DATE)=-1!($LENGTH(DATE,".")=1)
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,46)
QUIT
End DoDot:2
End DoDot:1
+124 IF $GET(PATDATEPREFS(1))
IF '$GET(PATDATEPREFS(2))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,195)
+125 IF $GET(PATDATEPREFS(3))
IF '$GET(PATDATEPREFS(4))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,195)
+126 IF $GET(PATDATEPREFS(5))
IF '$GET(PATDATEPREFS(6))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,195)
+127 IF $GET(MODALITY)'=""
IF $$VALIDATEMODALITY^SDESINPUTVALUTL(.SDAPTREQ,MODALITY)
SET POP=1
+128 QUIT
+129 ;
CREATE ;Build FDA array to add a new entry in 409.85
+1 SET AUDF=1
+2 SET FDA=$NAME(FDA(FNUM,"+1,"))
+3 SET @FDA@(.01)=+DFN
+4 if $GET(ARORIGDT)'=""
SET @FDA@(1)=ARORIGDT
+5 if $GET(INSTIEN)'=""
SET @FDA@(2)=INSTIEN
+6 if $GET(INSTIEN)=""&($GET(INST)'="")
SET @FDA@(2)=INST
+7 if $GET(TYPE)'=""
SET @FDA@(4)=TYPE
+8 if $GET(VAOSGUID)'=""
SET @FDA@(5)=VAOSGUID
+9 if $GET(MODALITY)'=""
SET @FDA@(6)=MODALITY
+10 if $GET(CLIN)'=""
SET @FDA@(8)=+CLIN
+11 if $GET(STOP)'=""
SET @FDA@(8.5)=+STOP
+12 if $GET(ARSTOPSEC)'=""
SET @FDA@(8.6)=+ARSTOPSEC
+13 if +APTYP
SET @FDA@(8.7)=+APTYP
+14 if $GET(USER)'=""
SET @FDA@(9)=+USER
+15 if $GET(EDT)'=""
SET @FDA@(9.5)=EDT
+16 if $GET(ARPRIO)'=""
SET @FDA@(10)=ARPRIO
+17 if $GET(ENPRI)'=""
SET @FDA@(10.5)=ENPRI
+18 if $GET(REQBY)'=""
SET @FDA@(11)=REQBY
+19 if $GET(PROV)'=""
SET @FDA@(12)=+PROV
+20 if $GET(DAPTDT)'=""
SET @FDA@(13)=DAPTDT
+21 if $GET(SVCCOP)'=""
SET @FDA@(14)=SVCCOP
+22 if $GET(SVCCON)'=""
SET @FDA@(15)=+SVCCON
+23 if $GET(DAPTDT)'=""
SET @FDA@(22)=DAPTDT
+24 if $GET(NLT)'=""
SET @FDA@(47)=NLT
+25 if EAS'=""
SET @FDA@(100)=EAS
+26 DO FDAPRER(.FDA,PRER,"+1")
+27 if $GET(ORDN)'=""
SET @FDA@(46)=ORDN
+28 SET @FDA@(23)="O"
+29 if $GET(COMM)'=""
SET @FDA@(25)=COMM
+30 if $GET(MAR)'=""
SET @FDA@(41)=MAR
+31 IF +MAR
IF $GET(MAI)'=""
SET @FDA@(42)=MAI
+32 IF +MAR
IF $GET(MAN)'=""
SET @FDA@(43)=MAN
+33 if PATSTAT'=""
SET @FDA@(.02)=PATSTAT
+34 if +PARENT
SET @FDA@(43.8)=+PARENT
+35 IF $GET(PARENT)
Begin DoDot:1
+36 SET @FDA@(43.1)=$$MRTCHILDSEQUENCE^SDECAR2($GET(PARENT),$GET(DFN))
End DoDot:1
+37 QUIT
+38 ;
UPDATE ;
+1 SET ARIEN=ARIEN_","
+2 KILL ARDATA,ARERR
+3 DO GETS^DIQ(FNUM,ARIEN,"*","IE","ARDATA","ARERR")
+4 IF $DATA(ARERR)
Begin DoDot:1
+5 SET POP=1
+6 KILL FDA
+7 FOR MI=1:1:$GET(ARERR("DIERR"))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,48,$GET(ARERR("DIERR",MI,"TEXT",1)))
End DoDot:1
QUIT
+8 SET FDA=$NAME(FDA(FNUM,ARIEN))
+9 IF ARORIGDT'=""
Begin DoDot:1
+10 SET ARORIGDT=$PIECE(ARORIGDT,"@",1)
SET ARORIGDTI=$$CALLDT(ARORIGDT)
+11 IF ARORIGDTI'=ARDATA(FNUM,ARIEN,1,"I")
SET @FDA@(1)=$SELECT(ARORIGDT="":"@",1:ARORIGDT)
End DoDot:1
+12 IF INSTIEN'=""
IF INSTIEN'=ARDATA(FNUM,ARIEN,2,"I")
SET @FDA@(2)=INSTIEN
+13 IF INSTIEN=""
IF INST'=""
SET @FDA@(2)=INST
+14 IF TYPE'=""
IF TYPE'=ARDATA(FNUM,ARIEN,4,"I")
SET @FDA@(4)=TYPE
+15 IF VAOSGUID'=""
IF VAOSGUID'=ARDATA(FNUM,ARIEN,5,"I")
SET @FDA@(5)=VAOSGUID
+16 IF MODALITY'=""
IF MODALITY'=ARDATA(FNUM,ARIEN,6,"I")
SET @FDA@(6)=MODALITY
+17 IF CLIN'=""
IF CLIN'=ARDATA(FNUM,ARIEN,8,"I")
SET @FDA@(8)=+CLIN
SET AUDF=1
Begin DoDot:1
+18 IF ARDATA(FNUM,ARIEN,8.5,"I")'=""
SET @FDA@(8.5)="@"
SET @FDA@(8.6)="@"
End DoDot:1
+19 IF STOP'=""
IF STOP'=ARDATA(FNUM,ARIEN,8.5,"I")
SET @FDA@(8.5)=+STOP
SET AUDF=1
if ARDATA(FNUM,ARIEN,8,"I")'=""
SET @FDA@(8)="@"
+20 IF ARSTOPSEC'=""
IF ARSTOPSEC'=ARDATA(FNUM,ARIEN,8.6,"I")
SET @FDA@(8.6)=+ARSTOPSEC
SET AUDF=1
if ARDATA(FNUM,ARIEN,8,"I")'=""
SET @FDA@(8)="@"
+21 if +APTYP
SET @FDA@(8.7)=+APTYP
+22 IF USER'=""
IF USER'=ARDATA(FNUM,ARIEN,9,"I")
SET @FDA@(9)=+USER
+23 IF EDT'=""
IF EDT'=$GET(ARDATA(FNUM,ARIEN,9.5,"I"))
SET @FDA@(9.5)=EDT
+24 IF ARPRIO'=""
IF ARPRIO'=ARDATA(FNUM,ARIEN,10,"I")
SET @FDA@(10)=$SELECT(ARPRIO="":"@",1:ARPRIO)
+25 IF ENPRI'=""
IF ENPRI'=ARDATA(FNUM,ARIEN,10.5,"I")
SET @FDA@(10.5)=ENPRI
+26 IF REQBY'=""
IF REQBY'=ARDATA(FNUM,ARIEN,11,"I")
SET @FDA@(11)=$SELECT(REQBY="":"@",1:REQBY)
+27 IF PROV'=""
IF PROV'=ARDATA(FNUM,ARIEN,12,"I")
SET @FDA@(12)=+PROV
+28 IF SVCCOP'=""
IF SVCCOP'=$GET(ARDATA(FNUM,ARIEN,14,"I"))
SET @FDA@(14)=SVCCOP
+29 IF SVCCON'=""
IF SVCCON'=ARDATA(FNUM,ARIEN,15,"I")
SET @FDA@(15)=+SVCCON
+30 IF DAPTDT'=""
IF DAPTDT'=ARDATA(FNUM,ARIEN,22,"I")
SET @FDA@(22)=$SELECT(DAPTDT="":"@",1:DAPTDT)
+31 IF COMM'=""
IF COMM'=ARDATA(FNUM,ARIEN,25,"I")
SET @FDA@(25)=$SELECT(COMM="":"@",1:COMM)
+32 if MAR'=""
SET @FDA@(41)=MAR
+33 if MAI'=""
SET @FDA@(42)=MAI
+34 if MAN'=""
SET @FDA@(43)=MAN
+35 if NLT'=""
SET @FDA@(47)=NLT
+36 if EAS'=""
SET @FDA@(100)=EAS
+37 DO DELPRER(+ARIEN)
+38 DO FDAPRER(.FDA,PRER,+ARIEN)
+39 if ORDN'=""
SET @FDA@(46)=ORDN
+40 if PATSTAT'=""
SET @FDA@(.02)=PATSTAT
+41 if +PARENT
SET @FDA@(43.8)=+PARENT
+42 QUIT
+43 ;
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 ;
FDAPRER(FDA,PRER,ARIEN) ;Setup the FDA array for the PREREQUISITE mult (#48)
+1 NEW ASEQ,DELIM,PC,PR
+2 if $GET(PRER)=""
QUIT
+3 SET DELIM=";"
SET ASEQ=80
+4 FOR PC=1:1:$LENGTH(PRER,DELIM)
Begin DoDot:1
+5 SET PR=$PIECE(PRER,DELIM,PC)
if PR=""
QUIT
+6 SET ASEQ=ASEQ+1
SET FDA(409.8548,"+"_ASEQ_","_ARIEN_",",.01)=PR
End DoDot:1
+7 QUIT
+8 ;
FILE ;Perform file update
+1 ;Only call UPDATE^DIE if there are entries in FDA
+2 if $DATA(FDA)>9
DO UPDATE^DIE("","FDA","ARRET","ARMSG")
+3 IF $DATA(ARMSG)
Begin DoDot:1
+4 FOR MI=1:1:$GET(ARMSG("DIERR"))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPTREQ,48,$GET(ARMSG("DIERR",MI,"TEXT",1)))
End DoDot:1
QUIT
+5 NEW IEN
+6 SET IEN=$SELECT(+ARIEN:+ARIEN,1:ARRET(1))
+7 SET INSTI=$PIECE($GET(^SDEC(409.85,IEN,0)),U,3)
+8 ;Pat contacts
IF $GET(PATCONT)'=""
DO AR23(PATCONT,IEN)
+9 ;MRTC CALC PREF DATES
IF +MAR
IF $GET(MRTCPREFDT)'=""
DO AR435(MRTCPREFDT,IEN)
+10 ;VS AUDIT
IF +AUDF
DO ARAUD(IEN,CLIN,STOP)
+11 IF $GET(MULTIAPTMADE)'=""
Begin DoDot:1
+12 NEW SDI
+13 FOR SDI=1:1:$LENGTH(MULTIAPTMADE,"|")
SET SDREC=$PIECE(MULTIAPTMADE,"|",SDI)
DO AR433(IEN,SDREC)
End DoDot:1
+14 IF +PARENT
DO AR433(+PARENT,"~"_IEN)
+15 ;file Pat entered comments if any sent
+16 IF PCMT]""
IF PCMT'["Patient preferred date range"
DO ARPCMT(IEN,PCMT)
+17 ;file Pat date preferences in comments mult
+18 IF $DATA(PATDATEPREFS(1))
IF $DATA(PATDATEPREFS(2))
IF '$GET(EDIT)
Begin DoDot:1
+19 SET PATDATEPREFS(1)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(1),CLIN)
SET PATDATEPREFS(1)=$$FMTE^XLFDT(PATDATEPREFS(1))
+20 SET PATDATEPREFS(2)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(2),CLIN)
SET PATDATEPREFS(2)=$$FMTE^XLFDT(PATDATEPREFS(2))
+21 SET RANGE(1)="Patient preferred date range #1: "_PATDATEPREFS(1)_" to "_PATDATEPREFS(2)
+22 IF $DATA(PATDATEPREFS(3))
IF $DATA(PATDATEPREFS(4))
Begin DoDot:2
+23 SET PATDATEPREFS(3)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(3),CLIN)
SET PATDATEPREFS(3)=$$FMTE^XLFDT(PATDATEPREFS(3))
+24 SET PATDATEPREFS(4)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(4),CLIN)
SET PATDATEPREFS(4)=$$FMTE^XLFDT(PATDATEPREFS(4))
+25 SET RANGE(2)="Patient preferred date range #2: "_PATDATEPREFS(3)_" to "_PATDATEPREFS(4)
End DoDot:2
+26 IF $DATA(PATDATEPREFS(5))
IF $DATA(PATDATEPREFS(6))
Begin DoDot:2
+27 SET PATDATEPREFS(5)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(5),CLIN)
SET PATDATEPREFS(5)=$$FMTE^XLFDT(PATDATEPREFS(5))
+28 SET PATDATEPREFS(6)=$$ISOTFM^SDAMUTDT(PATDATEPREFS(6),CLIN)
SET PATDATEPREFS(6)=$$FMTE^XLFDT(PATDATEPREFS(6))
+29 SET RANGE(3)="Patient preferred date range #3: "_PATDATEPREFS(5)_" to "_PATDATEPREFS(6)
End DoDot:2
+30 DO WP^DIE(409.85,IEN_",",60,"A","RANGE")
End DoDot:1
+31 IF $GET(EDIT)
Begin DoDot:1
+32 IF PCMT'["Patient preferred date range"
SET EDITPATCOM(1)=PCMT
DO WP^DIE(409.85,IEN_",",60,"","EDITPATCOM")
QUIT
+33 SET EDITPATCOM(1)=$PIECE($GET(PCMT),"Patient preferred date range",1)
+34 SET DATERANGE1=$PIECE($GET(PCMT),"Patient preferred date range",2)
IF $LENGTH($GET(DATERANGE1))
SET EDITPATCOM(2)="Patient preferred date range"_$PIECE($GET(PCMT),"Patient preferred date range",2)
+35 SET DATERANGE2=$PIECE($GET(PCMT),"Patient preferred date range",3)
IF $LENGTH($GET(DATERANGE2))
SET EDITPATCOM(3)="Patient preferred date range"_$PIECE($GET(PCMT),"Patient preferred date range",3)
+36 SET DATERANGE3=$PIECE($GET(PCMT),"Patient preferred date range",4)
IF $LENGTH($GET(DATERANGE3))
SET EDITPATCOM(4)="Patient preferred date range"_$PIECE($GET(PCMT),"Patient preferred date range",4)
+37 DO WP^DIE(409.85,IEN_",",60,"","EDITPATCOM")
End DoDot:1
+38 IF +$GET(ARRET(1))
SET SDAPTREQ("AptReqCreate","IEN")=IEN
+39 IF '$TEST
SET SDAPTREQ("AptReqUpdate","IEN")=IEN
+40 QUIT
+41 ;
ARPCMT(ARIEN,COMMENTSFLD60) ;populate word processing PATIENT COMMENTS (409.855,60)
+1 ;ARIEN-(req)IEN to entry in 409.85
+2 ;COMMENTSFLD60-(opt)VAOS related patient-entered comments
+3 NEW SDFDA,PCMTSARRAY
+4 SET COMMENTSFLD60=$GET(COMMENTSFLD60)
+5 DO WP^SDECUTL(.PCMTSARRAY,COMMENTSFLD60)
+6 DO WP^DIE(409.85,ARIEN_",",60,"","PCMTSARRAY")
+7 QUIT
+8 ;
ARAUD(ARIEN,CLIN,STOP,DATE,USER) ;populate VS AUDIT mult field 45
+1 ;ARIEN-(req)pointer to SDEC APPT REQUEST file 409.85
+2 ;CLIN-(opt)pointer to HOSPITAL LOCATION file 44
+3 ;STOP-(opt)pointer to CLINIC STOP file
+4 ;DATE-(opt)dt/tm in FileMan format
+5 NEW SDFDA,SDP,SDPN,ERRARRY
+6 SET ARIEN=$GET(ARIEN)
if ARIEN=""
QUIT
+7 SET CLIN=$GET(CLIN)
+8 SET STOP=$GET(STOP)
+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)=CLIN
IF $PIECE(SDPN,U,4)=STOP
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 CLIN'=""
SET SDFDA(409.8545,"+1,"_ARIEN_",",2)=CLIN
+16 if STOP'=""
SET SDFDA(409.8545,"+1,"_ARIEN_",",3)=STOP
+17 DO UPDATE^DIE("","SDFDA",,"ERRARRY")
+18 QUIT
+19 ;
AR433(ARIEN,SDEC) ;set MULT APPTS MADE
+1 ;INPUT:
+2 ; ARIEN=(req)pointer to SDEC APPT REQUEST file 409.85
+3 ;
+4 ;
+5 NEW SDAPP,SDFDA,SDI,SDIEN,ERRARRY
+6 SET ARIEN=$GET(ARIEN)
+7 if '$DATA(^SDEC(409.85,ARIEN,0))
QUIT
+8 SET SDEC=$GET(SDEC)
+9 FOR SDI=1:1:$LENGTH(SDEC,"|")
Begin DoDot:1
+10 KILL SDFDA
+11 SET SDAPP=$PIECE(SDEC,"|",SDI)
+12 IF $PIECE(SDAPP,"~",2)=""
IF $PIECE(SDAPP,"~",1)'=""
SET $PIECE(SDAPP,"~",2)=$PIECE($$GET1^DIQ(409.84,+SDAPP_",",.22,"I"),";",1)
+13 if $PIECE(SDAPP,"~",2)=""
QUIT
+14 SET SDIEN=$ORDER(^SDEC(409.85,ARIEN,2,"B",$PIECE(SDAPP,"~",2),0))
+15 SET SDIEN=$SELECT(SDIEN'="":SDIEN,1:"+1")
+16 IF $DATA(^SDEC(409.85,+$PIECE(SDAPP,"~",2),0))
SET SDFDA(409.852,SDIEN_","_ARIEN_",",.01)=+$PIECE(SDAPP,"~",2)
+17 IF $DATA(^SDEC(409.84,+$PIECE(SDAPP,"~",1),0))
SET SDFDA(409.852,SDIEN_","_ARIEN_",",.02)=+$PIECE(SDAPP,"~",1)
+18 if $DATA(SDFDA)
DO UPDATE^DIE("","SDFDA",,"ERRARRY")
End DoDot:1
+19 QUIT
+20 ;
AR435(SDDT,ARIEN) ;set dates into MRTC CALC PREF DATES mult 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 |. Each date can be in external format with no time.
+4 NEW SDI,SDJ,SDFDA,TMPDT,ERRARRY
+5 FOR SDI=1:1:$LENGTH(SDDT,"|")
Begin DoDot:1
+6 SET TMPDT=$PIECE($PIECE(SDDT,"|",SDI),"@",1)
+7 SET SDJ=$$CALLDT(TMPDT)
+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",,"ERRARRY")
End DoDot:1
+12 QUIT
+13 ;
AR23(INP17,ARI) ;Pat Contacts
+1 NEW STR17,ARASDH,ARDATA1,ARERR1,ARI1,ARIENS,ARIENS1,ARRET1,FDA,ARMSG1
+2 NEW ARDT,ARUSR
+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 ARDT=$PIECE($PIECE(STR17,"~~",1),":",1,2)
+9 SET ARDT=$$CALLDT(ARDT)
+10 IF (ARDT=-1)!(ARDT="")
QUIT
+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 dt/tm
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:USER)
+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 dt/tme
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",,"ARMSG1")
End DoDot:1
+26 QUIT
CALLDT(X) ;
+1 ;VSE-2396
QUIT $$ISOTFM^SDAMUTDT(X)
+2 ;
BUILDER ;Convert data to JSON
+1 NEW JSONERR
+2 SET JSONERR=""
+3 DO ENCODE^SDESJSON(.SDAPTREQ,.RETURN,.JSONERR)
+4 QUIT
