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