SDEC07 ;ALB/SAT,PC,KML,MGD,LAB,TJB/BLB,TJB,JAS - ADD NEW APPOINTMENT ; Oct 10,2024
;;5.3;Scheduling;**627,642,651,658,665,669,671,672,701,686,740,694,785,788,790,799,801,805,816,819,842,843,847,851,869,875,877,893**;Aug 13, 1993;Build 6
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to ^GMR(123 is supported by IA #4837
Q
APPADD(SDECY,SDECSTART,SDECEND,DFN,SDECRES,SDECLEN,SDECNOTE,SDECATID,SDECCR,SDMRTC,SDDDT,SDREQBY,SDLAB,PROVIEN,SDID,SDAPTYP,SDSVCP,SDSVCPR,SDCL,SDEKG,SDXRAY,APPTYPE,EESTAT,OVB,SDPARENT,SDEL,EAS) ;
N SDAPPTYP,CKATYP
N SDECERR,SDECIEN,SDECDEP,SDECI,SDECJ,SDECAPPTI,SDECDJ,SDECRESD,SDECRNOD,SDECC,SDECERR,SDECWKIN,ITYP,REQIEN
N SDECNOEV,SDECDEV,SDECDERR,SDECTMP,SAVESTRT,SDAREQ0,XQOPT
N %DT,X,Y,DGQUIET,OBM,RET
N SDOE,DONE
;Don't execute SDEC ADD APPOINTMENT protocol
S SDECNOEV=1
K ^TMP("SDEC07",$J)
S SDECERR=0
S SDECI=0
S SDECY="^TMP(""SDEC07"","_$J_")"
S ^TMP("SDEC07",$J,SDECI)="I00020APPOINTMENTID^T00020ERRORID"_$C(30)
S SDECI=SDECI+1
S ITYP="SDEC07 Error: Invalid Appointment Type"
S CKATYP=$P($G(SDAPTYP),"|",1)
I ("^A^C^R^"'[("^"_CKATYP_"^")) D ERR(SDECI+1,ITYP,,0) Q
S REQIEN=+$P($G(SDAPTYP),"|",2)
I 'REQIEN D ERR(SDECI+1,ITYP,,0) Q
I CKATYP="E" I '$D(^SDWL(409.3,REQIEN,0)) D ERR(SDECI+1,ITYP,,0) Q
I CKATYP="R" I '$D(^SD(403.5,REQIEN,0)) D ERR(SDECI+1,ITYP,,0) Q
I CKATYP="C" I '$D(^GMR(123,REQIEN,0)) D ERR(SDECI+1,ITYP,,0) Q
I CKATYP="A" I '$D(^SDEC(409.85,REQIEN,0)) D ERR(SDECI+1,ITYP,,0) Q
I CKATYP="A" S SDAREQ0=$G(^SDEC(409.85,REQIEN,0)) I $P(SDAREQ0,U,5)="RTC",$P(SDAREQ0,U,17)="C" D ERR(SDECI+1,"SDEC07 Error: This RTC request has been closed.",,0) Q
S SAVESTRT=SDECSTART
S ITYP="SDEC07 Error: The patient on the appointment request and the subsequent appointment must match."
I CKATYP="R" I DFN'=$$GET1^DIQ(403.5,REQIEN,.01,"I") D ERR(SDECI+1,ITYP,,0) Q
I CKATYP="C" I DFN'=$$GET1^DIQ(123,REQIEN,.02,"I") D ERR(SDECI+1,ITYP,,0) Q
I CKATYP="A" I DFN'=$$GET1^DIQ(409.85,REQIEN,.01,"I") D ERR(SDECI+1,ITYP,,0) Q
;
S SDECSTART=$$NETTOFM^SDECDATE(SDECSTART,"Y")
I SDECSTART=-1 D ERR(SDECI+1,"SDEC07 Error: Invalid Start Time",,0) Q
S SDECEND=$$NETTOFM^SDECDATE(SDECEND,"Y")
I SDECEND=-1 D ERR(SDECI+1,"SDEC07 Error: Invalid End Time",,0) Q
I $L(SDECEND,".")=1 D ERR(SDECI+1,"SDEC07 Error: Invalid End Time",,0) Q
I SDECSTART>SDECEND S SDECTMP=SDECEND,SDECEND=SDECSTART,SDECSTART=SDECTMP
S DFN=$G(DFN)
I DFN="" D ERR(SDECI+1,"SDEC07: Patient ID required.",,0) Q
I '$D(^DPT(DFN,0)) D ERR(SDECI+1,"SDEC07 Error: Invalid Patient ID",,0) Q
L +^DPT(DFN):3 I '$T D ERR(SDECI+1,"Patient is being edited. Try again later.",,0) Q
D OP^XQCHK
N POP
S POP=0
S:(CKATYP="A")&($P($G(XQOPT),U)'="SD RECEIVE OR") POP=$$ORDERLOCKCHECK^SDEC07C($P(SDAREQ0,"^",5),$P(SDAPTYP,"|",2),.SDECI,DFN)
Q:POP
; Reject if another appointment scheduled at same time.
I $D(^DPT(DFN,"S",SDECSTART)),$P(^(SDECSTART,0),U,2)'="C",$P(^(0),U,2)'="PC" D ERR(SDECI+1,"Appointment in "_$P(^SC($P(^(0),U,1),0),U,1)_" already scheduled at the same time.",DFN,1) Q ;SD,740
;Validate Resource
S SDECERR=0 K SDECRESD
S SDECRES=$G(SDECRES) I SDECRES="" D ERR(SDECI+1,"SDEC07 Error: Invalid Resource ID",DFN,1) Q
I +SDECRES,'$D(^SDEC(409.831,SDECRES,0)) D ERR(SDECI+1,"SDEC07 Error: Invalid Resource ID",DFN,1) Q
I '+SDECRES,'$D(^SDEC(409.831,"B",SDECRES)) D ERR(SDECI+1,"SDEC07 Error: Invalid Resource ID",DFN,1) Q
S SDECRESD=$S(+SDECRES:+SDECRES,1:$O(^SDEC(409.831,"B",SDECRES,0)))
S SDECRNOD=$G(^SDEC(409.831,SDECRESD,0))
I SDECRNOD="" D ERR(SDECI+1,"SDEC07 Error: Unable to add appointment -- invalid Resource entry.",DFN,1) Q
N PTR44,MAXDAYS S PTR44=$P(SDECRNOD,"^",4),MAXDAYS=390
I +PTR44,$D(^SC(PTR44,"SDP")) S MAXDAYS=$P(^("SDP"),"^",2) S:MAXDAYS="" MAXDAYS=390
I SDECSTART>$$FMADD^XLFDT($$NOW^XLFDT(),MAXDAYS) D ERR(SDECI+1,"Appointment date too far in the future",DFN,1) Q
S SDECWKIN=0
S SDECATID=$G(SDECATID)
I SDECATID="WALKIN" S SDECWKIN=1
I SDECATID'?.N&(SDECATID'="WALKIN") S SDECATID=""
S SDECLEN=$G(SDECLEN)
;validate MTRC flag (optional)
S SDMRTC=$$UP^XLFSTR($G(SDMRTC))
S SDMRTC=$S(SDMRTC="TRUE":1,1:0)
;validate desired date of appt (optional)
S SDDDT=$G(SDDDT)
I SDDDT'="" S %DT="" S X=$P(SDDDT,"@",1) D ^%DT S SDDDT=Y I Y=-1 S SDDDT=""
I SDDDT="",SDECATID'="WALKIN" S SDDDT=$P(SDECSTART,".",1)
;validate requested by
S SDREQBY=$$UP^XLFSTR($G(SDREQBY))
I SDREQBY'="" S SDREQBY=$S(SDREQBY="PROVIDER":1,SDREQBY="PATIENT":2,1:0)
;validate lab date/time (optional)
S SDLAB=$G(SDLAB)
I SDLAB'="" S %DT="T" S X=SDLAB D ^%DT S SDLAB=Y I Y=-1 S SDLAB=""
;validate EKG date/time (optional)
S SDEKG=$G(SDEKG)
I SDEKG'="" S %DT="T" S X=SDEKG D ^%DT S SDEKG=Y I Y=-1 S SDEKG=""
;validate XRAY date/time (optional)
S SDXRAY=$G(SDXRAY)
I SDXRAY'="" S %DT="T" S X=SDXRAY D ^%DT S SDXRAY=Y I Y=-1 S SDXRAY=""
S SDID=$G(SDID)
;validate clini101
S SDCL=$G(SDCL)
I SDCL'="" I '$D(^SC(SDCL,0)) S SDCL=""
;clinic ID ;support for single HOSPITAL LOCATION in SDEC RESOURCE
I SDCL="" S SDCL=$$GET1^DIQ(409.831,SDECRESD_",",.04,"I")
S OVB=+$G(OVB)
I 'OVB S OBM=$$OBM1^SDEC57(SDCL,SDECSTART,SDMRTC,,+SDECWKIN) I OBM'="",+OBM'=1 S SDECAPPTID=0 D ERR(SDECI+1,"OBM"_OBM,DFN,1) Q
;validate appt request type (required)
I SDCL="" D
.S:$P(SDAPTYP,"|",1)="E" SDCL=$$GET1^DIQ(409.3,$P(SDAPTYP,"|",2)_",",13.2,"I")
.S:$P(SDAPTYP,"|",1)="R" SDCL=$$GET1^DIQ(403.5,$P(SDAPTYP,"|",2)_",",4.5,"I")
.;ICR 4837 ICR states 'Zero node read into variable'
.S:$P(SDAPTYP,"|",1)="C" SDCL=$P($G(^GMR(123,+$P(SDAPTYP,"|",2),0)),U,4)
.S:$P(SDAPTYP,"|",1)="A" SDCL=$$GET1^DIQ(409.85,$P(SDAPTYP,"|",2)_",",8,"I")
I SDCL="" D ERR(SDECI+1,"SDEC07 Error: Invalid clinic ID.",DFN,1) Q
I $$INACTIVE^SDEC32(SDCL) D ERR(SDECI+1,"SDEC07 Error: "_$$GET1^DIQ(44,SDCL_",",.01)_" is an inactive clinic.",DFN,1) Q
;Reject if consult is not active or pending.
I $P(SDAPTYP,"|",1)="C" N CNSLTSTS,NOTOK S CNSLTSTS=$P($G(^GMR(123,+$P(SDAPTYP,"|",2),0)),U,12),NOTOK=0 D Q:NOTOK
. I CNSLTSTS'=5,CNSLTSTS'=6 D ERR(SDECI+1,"Consult status is not PENDING or ACTIVE. It cannot be scheduled.",DFN,1) S NOTOK=1 Q
;validate provider
S DONE=0
I $P(SDAPTYP,"|",1)'="R" D
. I $G(PROVIEN),'$D(^VA(200,+$G(PROVIEN),0)) D ERR(SDECI+1,"SDEC07 Error: Invalid provider ID.",DFN,1) S DONE=1
. I $G(PROVIEN)="" S PROVIEN=$$GETPROVIDER^SDESCREATEAPPT(SDCL,$P(SDAPTYP,"|",1),$P(SDAPTYP,"|",2))
I $P(SDAPTYP,"|",1)="R" D
. I $G(PROVIEN),'$$GET1^DIQ(403.54,PROVIEN,.01,"I") D ERR(SDECI+1,"SDEC07 Error: Invalid recall provider ID.",DFN,1) S DONE=1
Q:DONE
;validate service connected
S SDSVCPR=$G(SDSVCPR)
I SDSVCPR'="" S:(+SDSVCPR<0)!(+SDSVCPR>100) SDSVCPR=""
S SDSVCP=$G(SDSVCP)
S SDSVCP=$S(SDSVCP=0:0,SDSVCP="NO":0,SDSVCP=1:1,SDSVCP="YES":1,1:"")
;validate note - only use 1st 150 characters
S SDECNOTE=$G(SDECNOTE) S:SDECNOTE'="" SDECNOTE=$TR($E(SDECNOTE,1,150),"^"," ")
;validate APPTYPE
S APPTYPE=$G(APPTYPE) I APPTYPE'="",'$D(^SD(409.1,+APPTYPE,0)) S APPTYPE=""
;validate Patient Status (EESTAT)
S EESTAT=$G(EESTAT)
I EESTAT="" D
.I $P(SDAPTYP,"|",1)="E" S EESTAT=$$GET1^DIQ(409.3,$P(SDAPTYP,"|",2)_",",27,"I")
.I $P(SDAPTYP,"|",1)="A" S EESTAT=$$GET1^DIQ(409.3,$P(SDAPTYP,"|",2)_",",.02,"I")
S EESTAT=$S(EESTAT="N":"N",EESTAT="NEW":"N",EESTAT="E":"E",EESTAT="ESTABLISHED":"E",1:"")
;validate OVB (overbook)
S OVB=+$G(OVB)
I 'OVB D
.D OVBOOK^SDEC07A(.RET,SDCL,SDECSTART,SDECRES)
D
.S SDAPPTYP=+APPTYPE
.I 'SDAPPTYP D
..I $P(SDAPTYP,"|",1)="E" S SDAPPTYP=$$GET1^DIQ(409.3,+$P(SDAPTYP,"|",2)_",",8.7,"I")
..I $P(SDAPTYP,"|",1)="A" S SDAPPTYP=$$GET1^DIQ(409.85,+$P(SDAPTYP,"|",2)_",",8.7,"I")
..I $P(SDAPTYP,"|",1)="C",+APPTYPE S SDAPPTYP=+APPTYPE
.S:'SDAPPTYP SDAPPTYP=$O(^SD(409.1,"B","REGULAR",0))
S EAS=$TR($G(EAS),"^"," ")
I $L(EAS) S EAS=$$EASVALIDATE^SDESUTIL(EAS)
I EAS=-1 D ERR(SDECI+1,"SDEC07 Error: Invalid EAS Tracking Number",,0) Q
S SDECAPPTID=$$SDECADD(SDECSTART,SDECEND,DFN,SDECRESD,SDECATID,SDDDT,SDID,SDAPTYP,PROVIEN,SDCL,SDECNOTE,SAVESTRT,SDECRES,SDAPPTYP,EESTAT,1,+SDECLEN,EAS)
I 'SDECAPPTID D ERR(SDECI+1,"SDEC07 Error: Unable to add appointment to SDEC APPOINTMENT file.",DFN,2) Q
;Lock SDEC node & save appt
L +^SDEC(409.84,SDECAPPTID):5 I '$T D ERR(SDECI+1,"Another user is working with this patient's record. Please try again later",DFN,1) Q
S SDECDEV=""
I SDECATID="WALKIN",$G(SDECCR),$G(SDECDEV)'="" S DGQUIET=1 D WISD^SDECRT(DFN,$P(SDECSTART,"."),"",SDECDEV)
I SDECNOTE]"" D SDECWP(SDECAPPTID,SDECNOTE)
I +SDCL,$D(^SC(SDCL,0)) D I +SDECERR D ERR(SDECI+1,$P(SDECERR,U,2),DFN,2)
. S SDECC("PAT")=DFN
. S SDECC("CLN")=SDCL
. S SDECC("TYP")=$S(+SDECWKIN:4,SDAPPTYP=1:1,1:3)
. S SDECC("COL")=$S(SDAPPTYP=7:1,1:"")
. S SDECC("APT")=SDAPPTYP
. S SDECC("ADT")=SDECSTART
. S SDECC("LEN")=SDECLEN
. S SDECC("OI")=$E($G(SDECNOTE),1,150)
. S SDECC("OI")=$TR(SDECC("OI"),";"," ")
. S SDECC("OI")=$$STRIP(SDECC("OI"))
. S SDECC("RES")=SDECRESD
. S SDECC("USR")=DUZ
. S SDECC("MTR")=$G(SDMRTC)
. S SDECC("DDT")=SDDDT
. S SDECC("REQ")=SDREQBY
. S SDECC("LAB")=SDLAB
. S SDECC("XRA")=SDXRAY
. S SDECC("EKG")=SDEKG
. S SDECC("OVB")=$S(OVB=1:1,1:0)
. S SDECC("ELG")=SDEL
. S:$P(SDAPTYP,"|",1)="C" SDECC("CON")=$P(SDAPTYP,"|",2)
. S SDECERR=$$MAKE^SDEC07B(.SDECC)
. Q:SDECERR
. D AVUPDT^SDEC07C(SDCL,SDECSTART,SDECLEN)
. Q
I $P(SDAPTYP,"|",1)="E" D EWL^SDEC07A($P(SDAPTYP,"|",2),SDECSTART,SDCL,SDSVCPR,SDSVCP,,SDAPPTYP)
I $P(SDAPTYP,"|",1)="A" D
.D UPDATE^SDECAR2($P(SDAPTYP,"|",2),SDECSTART,SDCL,SDSVCPR,SDSVCP,,SDAPPTYP,EAS) ;alb/sat 658 do not pass note
.I $G(SDMRTC),$G(SDPARENT) D AR433^SDECAR2(SDPARENT,SDECAPPTID_"~"_$P(SDAPTYP,"|",2))
.D:$G(SDPARENT) AR438^SDECAR2($P(SDAPTYP,"|",2),SDPARENT)
N SDT S SDT=SDECSTART
I $$NOW^XLFDT>SDT,$$NEW^SDPCE(SDT) D
.N SDCOED
.S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
L -^SDEC(409.84,SDECAPPTID) ; Fixed Lock *790
L -^DPT(DFN)
S SDECI=SDECI+1
S ^TMP("SDEC07",$J,SDECI)=SDECAPPTID_"^"_$G(SDECDERR)_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC07",$J,SDECI)=$C(31)
Q
;ADD SDEC APPT ENTRY
SDECADD(SDECSTART,SDECEND,DFN,SDECRESD,SDECATID,SDDDT,SDID,SDAPTYP,PROVIEN,SDCL,SDECNOTE,SAVESTRT,SDECRES,SDAPPTYP,EESTAT,SDF,SDECLEN,EAS) ;alb/sat 665 add SDECLEN
N SDIEN,SDECAPPTID,SDECIEN,SDECMSG,SL,X,SDDFN,FDA,ERR,REQIEN
S SDECSTART=$G(SDECSTART)
S SAVESTRT=$G(SAVESTRT),SDECRES=$G(SDECRES)
S DFN=$G(DFN),SDDFN=DFN
S SDECRESD=$G(SDECRESD)
S SDECATID=$G(SDECATID)
S SDDDT=$G(SDDDT)
S SDID=$G(SDID)
S SDAPTYP=$G(SDAPTYP)
S SDAPPTYP=$G(SDAPPTYP)
S PROVIEN=$G(PROVIEN)
S SDCL=$G(SDCL)
S SDECEND=$G(SDECEND)
I $P(SDAPTYP,"|",1)="R" D
.S PROVIEN=$$GET1^DIQ(403.54,PROVIEN,.01,"I")
S SDECLEN=$G(SDECLEN)
I SDECLEN="",SDECEND="" S SDECLEN=+$G(^SC(SDCL,"SL")) S:'+SDECLEN SDECLEN=30 S SDECEND=$$FMADD^XLFDT(SDECSTART,,,+SDECLEN) ;no length or end date/time
I SDECLEN="",SDECEND'="" S SDECLEN=$$FMDIFF^XLFDT(SDECEND,SDECSTART,2)\60 ;no length
I SDECLEN'="",SDECEND="" S SDECEND=$$FMADD^XLFDT(SDECSTART,,,+SDECLEN) ;no end date/time
S SDECNOTE=$G(SDECNOTE)
S SDF=$G(SDF,0)
S EAS=$G(EAS)
I PROVIEN="" S PROVIEN=$$GET1^DIQ(44,SDCL_",",16,"I")
S SDIEN=$$APPTGET^SDECUTL(DFN,SDECSTART,SDCL)
S SDIEN=$S(SDIEN'="":SDIEN_",",1:"+1,") K FDA
S FDA(409.84,SDIEN,.01)=SDECSTART
S FDA(409.84,SDIEN,.02)=SDECEND
S FDA(409.84,SDIEN,.03)="@"
S FDA(409.84,SDIEN,.04)="@"
S FDA(409.84,SDIEN,.05)=DFN
S FDA(409.84,SDIEN,.06)=$S(+SDAPPTYP:SDAPPTYP,1:"@")
S FDA(409.84,SDIEN,.07)=SDECRESD
S FDA(409.84,SDIEN,.08)=$G(DUZ)
S FDA(409.84,SDIEN,.09)=$$NOW^XLFDT
S FDA(409.84,SDIEN,.1)="@"
S FDA(409.84,SDIEN,.101)="@"
S FDA(409.84,SDIEN,.102)="@"
S FDA(409.84,SDIEN,.11)="@"
S FDA(409.84,SDIEN,.12)="@"
S FDA(409.84,SDIEN,.121)="@"
S FDA(409.84,SDIEN,.122)="@"
S FDA(409.84,SDIEN,.13)=$S(SDECATID="WALKIN":"y",1:"@")
S FDA(409.84,SDIEN,.14)="@"
S FDA(409.84,SDIEN,.16)=$S(PROVIEN'="":PROVIEN,1:"@")
S FDA(409.84,SDIEN,.17)="@"
S FDA(409.84,SDIEN,.18)=$S($G(SDECLEN)'="":SDECLEN,1:"@")
S FDA(409.84,SDIEN,.2)=SDDDT
S FDA(409.84,SDIEN,.21)=$S($G(SDID)'="":SDID,1:"@")
S FDA(409.84,SDIEN,.22)=$S(SDAPTYP'="":$P(SDAPTYP,"|",2)_";"_$S($P(SDAPTYP,"|",1)="E":"SDWL(409.3,",$P(SDAPTYP,"|",1)="C":"GMR(123,",$P(SDAPTYP,"|",1)="R":"SD(403.5,",$P(SDAPTYP,"|",1)="A":"SDEC(409.85,",1:""),1:"@")
S FDA(409.84,SDIEN,.23)=$S($G(EESTAT)'="":EESTAT,1:"@")
S:EAS'="" FDA(409.84,SDIEN,100)=EAS
K SDECIEN,SDECMSG
D UPDATE^DIE("","FDA","SDECIEN","SDECMSG")
I $P(SDAPTYP,"|",1)="A"!($P(SDAPTYP,"|",1)="R") D
.S REQIEN=$P(SDAPTYP,"|",2)
.I $$LASTPIDCHECK^SDECAR2(REQIEN,SDDDT) D
..K FDA S FDA(409.854,"+1,"_REQIEN_",",.01)=$$NOW^XLFDT
..S FDA(409.854,"+1,"_REQIEN_",",1)=SDDDT
..S FDA(409.854,"+1,"_REQIEN_",",2)=$$GET1^DIQ(200,DUZ,.01,"E")
..D UPDATE^DIE(,"FDA",,"ERR") K FDA
S SDECAPPTID=$S(SDIEN'="+1,":+SDIEN,1:+$G(SDECIEN(1)))
K SDECMSG
I SDECNOTE="" D WP^DIE(409.84,$S(+$G(SDECAPPTID):SDECAPPTID_",",1:SDIEN_","),1,"","@","SDECMSG")
I SDECNOTE'="" D
. N ARR D WP^SDECUTL(.ARR,SDECNOTE) D WP^DIE(409.84,$S(+$G(SDECAPPTID):SDECAPPTID_",",1:SDIEN_","),1,"","ARR","SDECMSG")
. ; 409.84 NOTE AUDIT multiple
. N NAFDA,NAIENS
. S NAIENS=$S(+$G(SDECAPPTID):SDECAPPTID_",",1:SDIEN_",")
. S NAFDA(409.847,"+1,"_NAIENS,.01)=$$NOW^XLFDT
. S NAFDA(409.847,"+1,"_NAIENS,1)=DUZ
. S NAFDA(409.847,"+1,"_NAIENS,2)=SDECNOTE
. D UPDATE^DIE("","NAFDA") K NAFDA
I SDECAPPTID'="" D
.I $P(SDAPTYP,"|",1)="C",SDF D
..D CONSULTPID^SDEC07PID(SDAPTYP,DFN,PROVIEN,SAVESTRT,SDDDT,SDDFN,SDECNOTE,SDECRES)
.I $P(SDAPTYP,"|",1)="R" D ; VSE-863 ;6/9/2021
.. N SDCOMM,SDRET,SDRIEN1,SDRRFTR
.. S SDRIEN1=$P(SDAPTYP,"|",2)
.. S SDCOMM=$$GET1^DIQ(403.5,SDRIEN1,2.5)
.. S SDRRFTR="APPT SCHEDULED" ; "7"
.. D RECDSET^SDEC52A(.SDRET,SDRIEN1,SDRRFTR,SDCOMM)
I $G(SDECAPPTID) D SETMISSIONELIG^SDESMISSIONELG(SDECAPPTID)
Q SDECAPPTID
CONSPIDCHECK(SDRIEN1,SDDDT) ;
N CHIEN,CHSIEN,OLDPID
S CHIEN=$O(^SDEC(409.87,"B",SDRIEN1,0))
S CHSIEN=$O(^SDEC(409.87,CHIEN,1,9999999),-1)
S OLDPID=$$GET1^DIQ(409.871,CHSIEN_","_CHIEN_",",1,"I")
I OLDPID'=$G(SDDDT) Q 1
Q 0
SDECWP(SDECAPPTID,SDECNOTE) ;
;Add WP field
I SDECNOTE]"" S SDECNOTE(.5)=SDECNOTE,SDECNOTE=""
I $D(SDECNOTE(0)) S SDECNOTE(.5)=SDECNOTE(0) K SDECNOTE(0)
I $D(SDECNOTE(.5)) D
. D WP^DIE(409.84,SDECAPPTID_",",1,"","SDECNOTE","SDECMSG")
Q
ADDEVT(DFN,SDECSTART,SDECSC,SDCLA) ;EP
;Called by SDEC ADD APPOINTMENT protocol
;SDECSC=IEN of clinic in ^SC
;SDCLA=IEN for ^SC(SDECSC,"S",SDECSTART,1,SDCLA)
N SDECNOD,SDECLEN,SDECAPPTID,SDECNODP,SDECWKIN,SDECRES
Q:+$G(SDECNOEV)
I $D(^SDEC(409.831,"ALOC",SDECSC)) S SDECRES=$O(^SDEC(409.831,"ALOC",SDECSC,0))
Q:'+$G(SDECRES)
S SDECNOD=$G(^SC(SDECSC,"S",SDECSTART,1,SDCLA,0))
Q:SDECNOD=""
S SDECNODP=$G(^DPT(DFN,"S",SDECSTART,0))
S SDECWKIN=""
;Purpose of Visit field of DPT Appointment subfile
S:$P(SDECNODP,U,7)=4 SDECWKIN="WALKIN"
S SDECLEN=$P(SDECNOD,U,2)
Q:'+SDECLEN
S SDECEND=$$FMADD^XLFDT(SDECSTART,0,0,SDECLEN,0)
S SDECAPPTID=$$SDECADD(SDECSTART,SDECEND,DFN,SDECRES,SDECWKIN,,,,,SDECSC,,,,,,1,+SDECLEN) ;alb/sat 665 add SDECLEN
Q:'+SDECAPPTID
S SDECNOTE=$P(SDECNOD,U,4)
I SDECNOTE]"" D SDECWP(SDECAPPTID,SDECNOTE)
Q
STRIP(SDECZ) ;Replace control characters with spaces
N SDECI
F SDECI=1:1:$L(SDECZ) I (32>$A($E(SDECZ,SDECI))) S SDECZ=$E(SDECZ,1,SDECI-1)_" "_$E(SDECZ,SDECI+1,999)
Q SDECZ
ERR(SDECI,SDECERR,DFN,LOCK) ;Error processing SD,740
S DFN=$G(DFN)
S SDECI=SDECI+1
S SDECERR=$TR(SDECERR,"^","~")
S ^TMP("SDEC07",$J,SDECI)=$G(SDECAPPTID,0)_"^"_SDECERR_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC07",$J,SDECI)=$C(31)
I $G(LOCK)=1 L -^DPT(DFN)
I $G(LOCK)=2 L -^DPT(DFN)
I +$G(SDECAPPTID) L -^SDEC(409.84,SDECAPPTID)
Q
ETRAP ;EP Error trap entry
D ^%ZTER
I '$D(SDECI) N SDECI S SDECI=999999
S SDECI=SDECI+1
D ERR(SDECI,"SDEC07 Error")
Q
ERROR ;
D ERR1("Error")
Q
ERR1(SDECERR) ;Error processing
S SDECI=SDECI+1
S ^TMP("SDEC07",$J,SDECI)=SDECERR_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC07",$J,SDECI)=$C(31)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC07 16174 printed Dec 13, 2024@02:49:57 Page 2
SDEC07 ;ALB/SAT,PC,KML,MGD,LAB,TJB/BLB,TJB,JAS - ADD NEW APPOINTMENT ; Oct 10,2024
+1 ;;5.3;Scheduling;**627,642,651,658,665,669,671,672,701,686,740,694,785,788,790,799,801,805,816,819,842,843,847,851,869,875,877,893**;Aug 13, 1993;Build 6
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to ^GMR(123 is supported by IA #4837
+5 QUIT
APPADD(SDECY,SDECSTART,SDECEND,DFN,SDECRES,SDECLEN,SDECNOTE,SDECATID,SDECCR,SDMRTC,SDDDT,SDREQBY,SDLAB,PROVIEN,SDID,SDAPTYP,SDSVCP,SDSVCPR,SDCL,SDEKG,SDXRAY,APPTYPE,EESTAT,OVB,SDPARENT,SDEL,EAS) ;
+1 NEW SDAPPTYP,CKATYP
+2 NEW SDECERR,SDECIEN,SDECDEP,SDECI,SDECJ,SDECAPPTI,SDECDJ,SDECRESD,SDECRNOD,SDECC,SDECERR,SDECWKIN,ITYP,REQIEN
+3 NEW SDECNOEV,SDECDEV,SDECDERR,SDECTMP,SAVESTRT,SDAREQ0,XQOPT
+4 NEW %DT,X,Y,DGQUIET,OBM,RET
+5 NEW SDOE,DONE
+6 ;Don't execute SDEC ADD APPOINTMENT protocol
+7 SET SDECNOEV=1
+8 KILL ^TMP("SDEC07",$JOB)
+9 SET SDECERR=0
+10 SET SDECI=0
+11 SET SDECY="^TMP(""SDEC07"","_$JOB_")"
+12 SET ^TMP("SDEC07",$JOB,SDECI)="I00020APPOINTMENTID^T00020ERRORID"_$CHAR(30)
+13 SET SDECI=SDECI+1
+14 SET ITYP="SDEC07 Error: Invalid Appointment Type"
+15 SET CKATYP=$PIECE($GET(SDAPTYP),"|",1)
+16 IF ("^A^C^R^"'[("^"_CKATYP_"^"))
DO ERR(SDECI+1,ITYP,,0)
QUIT
+17 SET REQIEN=+$PIECE($GET(SDAPTYP),"|",2)
+18 IF 'REQIEN
DO ERR(SDECI+1,ITYP,,0)
QUIT
+19 IF CKATYP="E"
IF '$DATA(^SDWL(409.3,REQIEN,0))
DO ERR(SDECI+1,ITYP,,0)
QUIT
+20 IF CKATYP="R"
IF '$DATA(^SD(403.5,REQIEN,0))
DO ERR(SDECI+1,ITYP,,0)
QUIT
+21 IF CKATYP="C"
IF '$DATA(^GMR(123,REQIEN,0))
DO ERR(SDECI+1,ITYP,,0)
QUIT
+22 IF CKATYP="A"
IF '$DATA(^SDEC(409.85,REQIEN,0))
DO ERR(SDECI+1,ITYP,,0)
QUIT
+23 IF CKATYP="A"
SET SDAREQ0=$GET(^SDEC(409.85,REQIEN,0))
IF $PIECE(SDAREQ0,U,5)="RTC"
IF $PIECE(SDAREQ0,U,17)="C"
DO ERR(SDECI+1,"SDEC07 Error: This RTC request has been closed.",,0)
QUIT
+24 SET SAVESTRT=SDECSTART
+25 SET ITYP="SDEC07 Error: The patient on the appointment request and the subsequent appointment must match."
+26 IF CKATYP="R"
IF DFN'=$$GET1^DIQ(403.5,REQIEN,.01,"I")
DO ERR(SDECI+1,ITYP,,0)
QUIT
+27 IF CKATYP="C"
IF DFN'=$$GET1^DIQ(123,REQIEN,.02,"I")
DO ERR(SDECI+1,ITYP,,0)
QUIT
+28 IF CKATYP="A"
IF DFN'=$$GET1^DIQ(409.85,REQIEN,.01,"I")
DO ERR(SDECI+1,ITYP,,0)
QUIT
+29 ;
+30 SET SDECSTART=$$NETTOFM^SDECDATE(SDECSTART,"Y")
+31 IF SDECSTART=-1
DO ERR(SDECI+1,"SDEC07 Error: Invalid Start Time",,0)
QUIT
+32 SET SDECEND=$$NETTOFM^SDECDATE(SDECEND,"Y")
+33 IF SDECEND=-1
DO ERR(SDECI+1,"SDEC07 Error: Invalid End Time",,0)
QUIT
+34 IF $LENGTH(SDECEND,".")=1
DO ERR(SDECI+1,"SDEC07 Error: Invalid End Time",,0)
QUIT
+35 IF SDECSTART>SDECEND
SET SDECTMP=SDECEND
SET SDECEND=SDECSTART
SET SDECSTART=SDECTMP
+36 SET DFN=$GET(DFN)
+37 IF DFN=""
DO ERR(SDECI+1,"SDEC07: Patient ID required.",,0)
QUIT
+38 IF '$DATA(^DPT(DFN,0))
DO ERR(SDECI+1,"SDEC07 Error: Invalid Patient ID",,0)
QUIT
+39 LOCK +^DPT(DFN):3
IF '$TEST
DO ERR(SDECI+1,"Patient is being edited. Try again later.",,0)
QUIT
+40 DO OP^XQCHK
+41 NEW POP
+42 SET POP=0
+43 if (CKATYP="A")&($PIECE($GET(XQOPT),U)'="SD RECEIVE OR")
SET POP=$$ORDERLOCKCHECK^SDEC07C($PIECE(SDAREQ0,"^",5),$PIECE(SDAPTYP,"|",2),.SDECI,DFN)
+44 if POP
QUIT
+45 ; Reject if another appointment scheduled at same time.
+46 ;SD,740
IF $DATA(^DPT(DFN,"S",SDECSTART))
IF $PIECE(^(SDECSTART,0),U,2)'="C"
IF $PIECE(^(0),U,2)'="PC"
DO ERR(SDECI+1,"Appointment in "_$PIECE(^SC($PIECE(^(0),U,1),0),U,1)_" already scheduled at the same time.",DFN,1)
QUIT
+47 ;Validate Resource
+48 SET SDECERR=0
KILL SDECRESD
+49 SET SDECRES=$GET(SDECRES)
IF SDECRES=""
DO ERR(SDECI+1,"SDEC07 Error: Invalid Resource ID",DFN,1)
QUIT
+50 IF +SDECRES
IF '$DATA(^SDEC(409.831,SDECRES,0))
DO ERR(SDECI+1,"SDEC07 Error: Invalid Resource ID",DFN,1)
QUIT
+51 IF '+SDECRES
IF '$DATA(^SDEC(409.831,"B",SDECRES))
DO ERR(SDECI+1,"SDEC07 Error: Invalid Resource ID",DFN,1)
QUIT
+52 SET SDECRESD=$SELECT(+SDECRES:+SDECRES,1:$ORDER(^SDEC(409.831,"B",SDECRES,0)))
+53 SET SDECRNOD=$GET(^SDEC(409.831,SDECRESD,0))
+54 IF SDECRNOD=""
DO ERR(SDECI+1,"SDEC07 Error: Unable to add appointment -- invalid Resource entry.",DFN,1)
QUIT
+55 NEW PTR44,MAXDAYS
SET PTR44=$PIECE(SDECRNOD,"^",4)
SET MAXDAYS=390
+56 IF +PTR44
IF $DATA(^SC(PTR44,"SDP"))
SET MAXDAYS=$PIECE(^("SDP"),"^",2)
if MAXDAYS=""
SET MAXDAYS=390
+57 IF SDECSTART>$$FMADD^XLFDT($$NOW^XLFDT(),MAXDAYS)
DO ERR(SDECI+1,"Appointment date too far in the future",DFN,1)
QUIT
+58 SET SDECWKIN=0
+59 SET SDECATID=$GET(SDECATID)
+60 IF SDECATID="WALKIN"
SET SDECWKIN=1
+61 IF SDECATID'?.N&(SDECATID'="WALKIN")
SET SDECATID=""
+62 SET SDECLEN=$GET(SDECLEN)
+63 ;validate MTRC flag (optional)
+64 SET SDMRTC=$$UP^XLFSTR($GET(SDMRTC))
+65 SET SDMRTC=$SELECT(SDMRTC="TRUE":1,1:0)
+66 ;validate desired date of appt (optional)
+67 SET SDDDT=$GET(SDDDT)
+68 IF SDDDT'=""
SET %DT=""
SET X=$PIECE(SDDDT,"@",1)
DO ^%DT
SET SDDDT=Y
IF Y=-1
SET SDDDT=""
+69 IF SDDDT=""
IF SDECATID'="WALKIN"
SET SDDDT=$PIECE(SDECSTART,".",1)
+70 ;validate requested by
+71 SET SDREQBY=$$UP^XLFSTR($GET(SDREQBY))
+72 IF SDREQBY'=""
SET SDREQBY=$SELECT(SDREQBY="PROVIDER":1,SDREQBY="PATIENT":2,1:0)
+73 ;validate lab date/time (optional)
+74 SET SDLAB=$GET(SDLAB)
+75 IF SDLAB'=""
SET %DT="T"
SET X=SDLAB
DO ^%DT
SET SDLAB=Y
IF Y=-1
SET SDLAB=""
+76 ;validate EKG date/time (optional)
+77 SET SDEKG=$GET(SDEKG)
+78 IF SDEKG'=""
SET %DT="T"
SET X=SDEKG
DO ^%DT
SET SDEKG=Y
IF Y=-1
SET SDEKG=""
+79 ;validate XRAY date/time (optional)
+80 SET SDXRAY=$GET(SDXRAY)
+81 IF SDXRAY'=""
SET %DT="T"
SET X=SDXRAY
DO ^%DT
SET SDXRAY=Y
IF Y=-1
SET SDXRAY=""
+82 SET SDID=$GET(SDID)
+83 ;validate clini101
+84 SET SDCL=$GET(SDCL)
+85 IF SDCL'=""
IF '$DATA(^SC(SDCL,0))
SET SDCL=""
+86 ;clinic ID ;support for single HOSPITAL LOCATION in SDEC RESOURCE
+87 IF SDCL=""
SET SDCL=$$GET1^DIQ(409.831,SDECRESD_",",.04,"I")
+88 SET OVB=+$GET(OVB)
+89 IF 'OVB
SET OBM=$$OBM1^SDEC57(SDCL,SDECSTART,SDMRTC,,+SDECWKIN)
IF OBM'=""
IF +OBM'=1
SET SDECAPPTID=0
DO ERR(SDECI+1,"OBM"_OBM,DFN,1)
QUIT
+90 ;validate appt request type (required)
+91 IF SDCL=""
Begin DoDot:1
+92 if $PIECE(SDAPTYP,"|",1)="E"
SET SDCL=$$GET1^DIQ(409.3,$PIECE(SDAPTYP,"|",2)_",",13.2,"I")
+93 if $PIECE(SDAPTYP,"|",1)="R"
SET SDCL=$$GET1^DIQ(403.5,$PIECE(SDAPTYP,"|",2)_",",4.5,"I")
+94 ;ICR 4837 ICR states 'Zero node read into variable'
+95 if $PIECE(SDAPTYP,"|",1)="C"
SET SDCL=$PIECE($GET(^GMR(123,+$PIECE(SDAPTYP,"|",2),0)),U,4)
+96 if $PIECE(SDAPTYP,"|",1)="A"
SET SDCL=$$GET1^DIQ(409.85,$PIECE(SDAPTYP,"|",2)_",",8,"I")
End DoDot:1
+97 IF SDCL=""
DO ERR(SDECI+1,"SDEC07 Error: Invalid clinic ID.",DFN,1)
QUIT
+98 IF $$INACTIVE^SDEC32(SDCL)
DO ERR(SDECI+1,"SDEC07 Error: "_$$GET1^DIQ(44,SDCL_",",.01)_" is an inactive clinic.",DFN,1)
QUIT
+99 ;Reject if consult is not active or pending.
+100 IF $PIECE(SDAPTYP,"|",1)="C"
NEW CNSLTSTS,NOTOK
SET CNSLTSTS=$PIECE($GET(^GMR(123,+$PIECE(SDAPTYP,"|",2),0)),U,12)
SET NOTOK=0
Begin DoDot:1
+101 IF CNSLTSTS'=5
IF CNSLTSTS'=6
DO ERR(SDECI+1,"Consult status is not PENDING or ACTIVE. It cannot be scheduled.",DFN,1)
SET NOTOK=1
QUIT
End DoDot:1
if NOTOK
QUIT
+102 ;validate provider
+103 SET DONE=0
+104 IF $PIECE(SDAPTYP,"|",1)'="R"
Begin DoDot:1
+105 IF $GET(PROVIEN)
IF '$DATA(^VA(200,+$GET(PROVIEN),0))
DO ERR(SDECI+1,"SDEC07 Error: Invalid provider ID.",DFN,1)
SET DONE=1
+106 IF $GET(PROVIEN)=""
SET PROVIEN=$$GETPROVIDER^SDESCREATEAPPT(SDCL,$PIECE(SDAPTYP,"|",1),$PIECE(SDAPTYP,"|",2))
End DoDot:1
+107 IF $PIECE(SDAPTYP,"|",1)="R"
Begin DoDot:1
+108 IF $GET(PROVIEN)
IF '$$GET1^DIQ(403.54,PROVIEN,.01,"I")
DO ERR(SDECI+1,"SDEC07 Error: Invalid recall provider ID.",DFN,1)
SET DONE=1
End DoDot:1
+109 if DONE
QUIT
+110 ;validate service connected
+111 SET SDSVCPR=$GET(SDSVCPR)
+112 IF SDSVCPR'=""
if (+SDSVCPR<0)!(+SDSVCPR>100)
SET SDSVCPR=""
+113 SET SDSVCP=$GET(SDSVCP)
+114 SET SDSVCP=$SELECT(SDSVCP=0:0,SDSVCP="NO":0,SDSVCP=1:1,SDSVCP="YES":1,1:"")
+115 ;validate note - only use 1st 150 characters
+116 SET SDECNOTE=$GET(SDECNOTE)
if SDECNOTE'=""
SET SDECNOTE=$TRANSLATE($EXTRACT(SDECNOTE,1,150),"^"," ")
+117 ;validate APPTYPE
+118 SET APPTYPE=$GET(APPTYPE)
IF APPTYPE'=""
IF '$DATA(^SD(409.1,+APPTYPE,0))
SET APPTYPE=""
+119 ;validate Patient Status (EESTAT)
+120 SET EESTAT=$GET(EESTAT)
+121 IF EESTAT=""
Begin DoDot:1
+122 IF $PIECE(SDAPTYP,"|",1)="E"
SET EESTAT=$$GET1^DIQ(409.3,$PIECE(SDAPTYP,"|",2)_",",27,"I")
+123 IF $PIECE(SDAPTYP,"|",1)="A"
SET EESTAT=$$GET1^DIQ(409.3,$PIECE(SDAPTYP,"|",2)_",",.02,"I")
End DoDot:1
+124 SET EESTAT=$SELECT(EESTAT="N":"N",EESTAT="NEW":"N",EESTAT="E":"E",EESTAT="ESTABLISHED":"E",1:"")
+125 ;validate OVB (overbook)
+126 SET OVB=+$GET(OVB)
+127 IF 'OVB
Begin DoDot:1
+128 DO OVBOOK^SDEC07A(.RET,SDCL,SDECSTART,SDECRES)
End DoDot:1
+129 Begin DoDot:1
+130 SET SDAPPTYP=+APPTYPE
+131 IF 'SDAPPTYP
Begin DoDot:2
+132 IF $PIECE(SDAPTYP,"|",1)="E"
SET SDAPPTYP=$$GET1^DIQ(409.3,+$PIECE(SDAPTYP,"|",2)_",",8.7,"I")
+133 IF $PIECE(SDAPTYP,"|",1)="A"
SET SDAPPTYP=$$GET1^DIQ(409.85,+$PIECE(SDAPTYP,"|",2)_",",8.7,"I")
+134 IF $PIECE(SDAPTYP,"|",1)="C"
IF +APPTYPE
SET SDAPPTYP=+APPTYPE
End DoDot:2
+135 if 'SDAPPTYP
SET SDAPPTYP=$ORDER(^SD(409.1,"B","REGULAR",0))
End DoDot:1
+136 SET EAS=$TRANSLATE($GET(EAS),"^"," ")
+137 IF $LENGTH(EAS)
SET EAS=$$EASVALIDATE^SDESUTIL(EAS)
+138 IF EAS=-1
DO ERR(SDECI+1,"SDEC07 Error: Invalid EAS Tracking Number",,0)
QUIT
+139 SET SDECAPPTID=$$SDECADD(SDECSTART,SDECEND,DFN,SDECRESD,SDECATID,SDDDT,SDID,SDAPTYP,PROVIEN,SDCL,SDECNOTE,SAVESTRT,SDECRES,SDAPPTYP,EESTAT,1,+SDECLEN,EAS)
+140 IF 'SDECAPPTID
DO ERR(SDECI+1,"SDEC07 Error: Unable to add appointment to SDEC APPOINTMENT file.",DFN,2)
QUIT
+141 ;Lock SDEC node & save appt
+142 LOCK +^SDEC(409.84,SDECAPPTID):5
IF '$TEST
DO ERR(SDECI+1,"Another user is working with this patient's record. Please try again later",DFN,1)
QUIT
+143 SET SDECDEV=""
+144 IF SDECATID="WALKIN"
IF $GET(SDECCR)
IF $GET(SDECDEV)'=""
SET DGQUIET=1
DO WISD^SDECRT(DFN,$PIECE(SDECSTART,"."),"",SDECDEV)
+145 IF SDECNOTE]""
DO SDECWP(SDECAPPTID,SDECNOTE)
+146 IF +SDCL
IF $DATA(^SC(SDCL,0))
Begin DoDot:1
+147 SET SDECC("PAT")=DFN
+148 SET SDECC("CLN")=SDCL
+149 SET SDECC("TYP")=$SELECT(+SDECWKIN:4,SDAPPTYP=1:1,1:3)
+150 SET SDECC("COL")=$SELECT(SDAPPTYP=7:1,1:"")
+151 SET SDECC("APT")=SDAPPTYP
+152 SET SDECC("ADT")=SDECSTART
+153 SET SDECC("LEN")=SDECLEN
+154 SET SDECC("OI")=$EXTRACT($GET(SDECNOTE),1,150)
+155 SET SDECC("OI")=$TRANSLATE(SDECC("OI"),";"," ")
+156 SET SDECC("OI")=$$STRIP(SDECC("OI"))
+157 SET SDECC("RES")=SDECRESD
+158 SET SDECC("USR")=DUZ
+159 SET SDECC("MTR")=$GET(SDMRTC)
+160 SET SDECC("DDT")=SDDDT
+161 SET SDECC("REQ")=SDREQBY
+162 SET SDECC("LAB")=SDLAB
+163 SET SDECC("XRA")=SDXRAY
+164 SET SDECC("EKG")=SDEKG
+165 SET SDECC("OVB")=$SELECT(OVB=1:1,1:0)
+166 SET SDECC("ELG")=SDEL
+167 if $PIECE(SDAPTYP,"|",1)="C"
SET SDECC("CON")=$PIECE(SDAPTYP,"|",2)
+168 SET SDECERR=$$MAKE^SDEC07B(.SDECC)
+169 if SDECERR
QUIT
+170 DO AVUPDT^SDEC07C(SDCL,SDECSTART,SDECLEN)
+171 QUIT
End DoDot:1
IF +SDECERR
DO ERR(SDECI+1,$PIECE(SDECERR,U,2),DFN,2)
+172 IF $PIECE(SDAPTYP,"|",1)="E"
DO EWL^SDEC07A($PIECE(SDAPTYP,"|",2),SDECSTART,SDCL,SDSVCPR,SDSVCP,,SDAPPTYP)
+173 IF $PIECE(SDAPTYP,"|",1)="A"
Begin DoDot:1
+174 ;alb/sat 658 do not pass note
DO UPDATE^SDECAR2($PIECE(SDAPTYP,"|",2),SDECSTART,SDCL,SDSVCPR,SDSVCP,,SDAPPTYP,EAS)
+175 IF $GET(SDMRTC)
IF $GET(SDPARENT)
DO AR433^SDECAR2(SDPARENT,SDECAPPTID_"~"_$PIECE(SDAPTYP,"|",2))
+176 if $GET(SDPARENT)
DO AR438^SDECAR2($PIECE(SDAPTYP,"|",2),SDPARENT)
End DoDot:1
+177 NEW SDT
SET SDT=SDECSTART
+178 IF $$NOW^XLFDT>SDT
IF $$NEW^SDPCE(SDT)
Begin DoDot:1
+179 NEW SDCOED
+180 SET SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
End DoDot:1
+181 ; Fixed Lock *790
LOCK -^SDEC(409.84,SDECAPPTID)
+182 LOCK -^DPT(DFN)
+183 SET SDECI=SDECI+1
+184 SET ^TMP("SDEC07",$JOB,SDECI)=SDECAPPTID_"^"_$GET(SDECDERR)_$CHAR(30)
+185 SET SDECI=SDECI+1
+186 SET ^TMP("SDEC07",$JOB,SDECI)=$CHAR(31)
+187 QUIT
+188 ;ADD SDEC APPT ENTRY
SDECADD(SDECSTART,SDECEND,DFN,SDECRESD,SDECATID,SDDDT,SDID,SDAPTYP,PROVIEN,SDCL,SDECNOTE,SAVESTRT,SDECRES,SDAPPTYP,EESTAT,SDF,SDECLEN,EAS) ;alb/sat 665 add SDECLEN
+1 NEW SDIEN,SDECAPPTID,SDECIEN,SDECMSG,SL,X,SDDFN,FDA,ERR,REQIEN
+2 SET SDECSTART=$GET(SDECSTART)
+3 SET SAVESTRT=$GET(SAVESTRT)
SET SDECRES=$GET(SDECRES)
+4 SET DFN=$GET(DFN)
SET SDDFN=DFN
+5 SET SDECRESD=$GET(SDECRESD)
+6 SET SDECATID=$GET(SDECATID)
+7 SET SDDDT=$GET(SDDDT)
+8 SET SDID=$GET(SDID)
+9 SET SDAPTYP=$GET(SDAPTYP)
+10 SET SDAPPTYP=$GET(SDAPPTYP)
+11 SET PROVIEN=$GET(PROVIEN)
+12 SET SDCL=$GET(SDCL)
+13 SET SDECEND=$GET(SDECEND)
+14 IF $PIECE(SDAPTYP,"|",1)="R"
Begin DoDot:1
+15 SET PROVIEN=$$GET1^DIQ(403.54,PROVIEN,.01,"I")
End DoDot:1
+16 SET SDECLEN=$GET(SDECLEN)
+17 ;no length or end date/time
IF SDECLEN=""
IF SDECEND=""
SET SDECLEN=+$GET(^SC(SDCL,"SL"))
if '+SDECLEN
SET SDECLEN=30
SET SDECEND=$$FMADD^XLFDT(SDECSTART,,,+SDECLEN)
+18 ;no length
IF SDECLEN=""
IF SDECEND'=""
SET SDECLEN=$$FMDIFF^XLFDT(SDECEND,SDECSTART,2)\60
+19 ;no end date/time
IF SDECLEN'=""
IF SDECEND=""
SET SDECEND=$$FMADD^XLFDT(SDECSTART,,,+SDECLEN)
+20 SET SDECNOTE=$GET(SDECNOTE)
+21 SET SDF=$GET(SDF,0)
+22 SET EAS=$GET(EAS)
+23 IF PROVIEN=""
SET PROVIEN=$$GET1^DIQ(44,SDCL_",",16,"I")
+24 SET SDIEN=$$APPTGET^SDECUTL(DFN,SDECSTART,SDCL)
+25 SET SDIEN=$SELECT(SDIEN'="":SDIEN_",",1:"+1,")
KILL FDA
+26 SET FDA(409.84,SDIEN,.01)=SDECSTART
+27 SET FDA(409.84,SDIEN,.02)=SDECEND
+28 SET FDA(409.84,SDIEN,.03)="@"
+29 SET FDA(409.84,SDIEN,.04)="@"
+30 SET FDA(409.84,SDIEN,.05)=DFN
+31 SET FDA(409.84,SDIEN,.06)=$SELECT(+SDAPPTYP:SDAPPTYP,1:"@")
+32 SET FDA(409.84,SDIEN,.07)=SDECRESD
+33 SET FDA(409.84,SDIEN,.08)=$GET(DUZ)
+34 SET FDA(409.84,SDIEN,.09)=$$NOW^XLFDT
+35 SET FDA(409.84,SDIEN,.1)="@"
+36 SET FDA(409.84,SDIEN,.101)="@"
+37 SET FDA(409.84,SDIEN,.102)="@"
+38 SET FDA(409.84,SDIEN,.11)="@"
+39 SET FDA(409.84,SDIEN,.12)="@"
+40 SET FDA(409.84,SDIEN,.121)="@"
+41 SET FDA(409.84,SDIEN,.122)="@"
+42 SET FDA(409.84,SDIEN,.13)=$SELECT(SDECATID="WALKIN":"y",1:"@")
+43 SET FDA(409.84,SDIEN,.14)="@"
+44 SET FDA(409.84,SDIEN,.16)=$SELECT(PROVIEN'="":PROVIEN,1:"@")
+45 SET FDA(409.84,SDIEN,.17)="@"
+46 SET FDA(409.84,SDIEN,.18)=$SELECT($GET(SDECLEN)'="":SDECLEN,1:"@")
+47 SET FDA(409.84,SDIEN,.2)=SDDDT
+48 SET FDA(409.84,SDIEN,.21)=$SELECT($GET(SDID)'="":SDID,1:"@")
+49 SET FDA(409.84,SDIEN,.22)=$SELECT(SDAPTYP'="":$PIECE(SDAPTYP,"|",2)_";"_$SELECT($PIECE(SDAPTYP,"|",1)="E":"SDWL(409.3,",$PIECE(SDAPTYP,"|",1)="C":"GMR(123,",$PIECE(SDAPTYP,"|",1)="R":"SD(403.5,",$PIECE(SDAPTYP,"|",1)="A":"SDEC(409.85,",1:""),1:
"@")
+50 SET FDA(409.84,SDIEN,.23)=$SELECT($GET(EESTAT)'="":EESTAT,1:"@")
+51 if EAS'=""
SET FDA(409.84,SDIEN,100)=EAS
+52 KILL SDECIEN,SDECMSG
+53 DO UPDATE^DIE("","FDA","SDECIEN","SDECMSG")
+54 IF $PIECE(SDAPTYP,"|",1)="A"!($PIECE(SDAPTYP,"|",1)="R")
Begin DoDot:1
+55 SET REQIEN=$PIECE(SDAPTYP,"|",2)
+56 IF $$LASTPIDCHECK^SDECAR2(REQIEN,SDDDT)
Begin DoDot:2
+57 KILL FDA
SET FDA(409.854,"+1,"_REQIEN_",",.01)=$$NOW^XLFDT
+58 SET FDA(409.854,"+1,"_REQIEN_",",1)=SDDDT
+59 SET FDA(409.854,"+1,"_REQIEN_",",2)=$$GET1^DIQ(200,DUZ,.01,"E")
+60 DO UPDATE^DIE(,"FDA",,"ERR")
KILL FDA
End DoDot:2
End DoDot:1
+61 SET SDECAPPTID=$SELECT(SDIEN'="+1,":+SDIEN,1:+$GET(SDECIEN(1)))
+62 KILL SDECMSG
+63 IF SDECNOTE=""
DO WP^DIE(409.84,$SELECT(+$GET(SDECAPPTID):SDECAPPTID_",",1:SDIEN_","),1,"","@","SDECMSG")
+64 IF SDECNOTE'=""
Begin DoDot:1
+65 NEW ARR
DO WP^SDECUTL(.ARR,SDECNOTE)
DO WP^DIE(409.84,$SELECT(+$GET(SDECAPPTID):SDECAPPTID_",",1:SDIEN_","),1,"","ARR","SDECMSG")
+66 ; 409.84 NOTE AUDIT multiple
+67 NEW NAFDA,NAIENS
+68 SET NAIENS=$SELECT(+$GET(SDECAPPTID):SDECAPPTID_",",1:SDIEN_",")
+69 SET NAFDA(409.847,"+1,"_NAIENS,.01)=$$NOW^XLFDT
+70 SET NAFDA(409.847,"+1,"_NAIENS,1)=DUZ
+71 SET NAFDA(409.847,"+1,"_NAIENS,2)=SDECNOTE
+72 DO UPDATE^DIE("","NAFDA")
KILL NAFDA
End DoDot:1
+73 IF SDECAPPTID'=""
Begin DoDot:1
+74 IF $PIECE(SDAPTYP,"|",1)="C"
IF SDF
Begin DoDot:2
+75 DO CONSULTPID^SDEC07PID(SDAPTYP,DFN,PROVIEN,SAVESTRT,SDDDT,SDDFN,SDECNOTE,SDECRES)
End DoDot:2
+76 ; VSE-863 ;6/9/2021
IF $PIECE(SDAPTYP,"|",1)="R"
Begin DoDot:2
+77 NEW SDCOMM,SDRET,SDRIEN1,SDRRFTR
+78 SET SDRIEN1=$PIECE(SDAPTYP,"|",2)
+79 SET SDCOMM=$$GET1^DIQ(403.5,SDRIEN1,2.5)
+80 ; "7"
SET SDRRFTR="APPT SCHEDULED"
+81 DO RECDSET^SDEC52A(.SDRET,SDRIEN1,SDRRFTR,SDCOMM)
End DoDot:2
End DoDot:1
+82 IF $GET(SDECAPPTID)
DO SETMISSIONELIG^SDESMISSIONELG(SDECAPPTID)
+83 QUIT SDECAPPTID
CONSPIDCHECK(SDRIEN1,SDDDT) ;
+1 NEW CHIEN,CHSIEN,OLDPID
+2 SET CHIEN=$ORDER(^SDEC(409.87,"B",SDRIEN1,0))
+3 SET CHSIEN=$ORDER(^SDEC(409.87,CHIEN,1,9999999),-1)
+4 SET OLDPID=$$GET1^DIQ(409.871,CHSIEN_","_CHIEN_",",1,"I")
+5 IF OLDPID'=$GET(SDDDT)
QUIT 1
+6 QUIT 0
SDECWP(SDECAPPTID,SDECNOTE) ;
+1 ;Add WP field
+2 IF SDECNOTE]""
SET SDECNOTE(.5)=SDECNOTE
SET SDECNOTE=""
+3 IF $DATA(SDECNOTE(0))
SET SDECNOTE(.5)=SDECNOTE(0)
KILL SDECNOTE(0)
+4 IF $DATA(SDECNOTE(.5))
Begin DoDot:1
+5 DO WP^DIE(409.84,SDECAPPTID_",",1,"","SDECNOTE","SDECMSG")
End DoDot:1
+6 QUIT
ADDEVT(DFN,SDECSTART,SDECSC,SDCLA) ;EP
+1 ;Called by SDEC ADD APPOINTMENT protocol
+2 ;SDECSC=IEN of clinic in ^SC
+3 ;SDCLA=IEN for ^SC(SDECSC,"S",SDECSTART,1,SDCLA)
+4 NEW SDECNOD,SDECLEN,SDECAPPTID,SDECNODP,SDECWKIN,SDECRES
+5 if +$GET(SDECNOEV)
QUIT
+6 IF $DATA(^SDEC(409.831,"ALOC",SDECSC))
SET SDECRES=$ORDER(^SDEC(409.831,"ALOC",SDECSC,0))
+7 if '+$GET(SDECRES)
QUIT
+8 SET SDECNOD=$GET(^SC(SDECSC,"S",SDECSTART,1,SDCLA,0))
+9 if SDECNOD=""
QUIT
+10 SET SDECNODP=$GET(^DPT(DFN,"S",SDECSTART,0))
+11 SET SDECWKIN=""
+12 ;Purpose of Visit field of DPT Appointment subfile
+13 if $PIECE(SDECNODP,U,7)=4
SET SDECWKIN="WALKIN"
+14 SET SDECLEN=$PIECE(SDECNOD,U,2)
+15 if '+SDECLEN
QUIT
+16 SET SDECEND=$$FMADD^XLFDT(SDECSTART,0,0,SDECLEN,0)
+17 ;alb/sat 665 add SDECLEN
SET SDECAPPTID=$$SDECADD(SDECSTART,SDECEND,DFN,SDECRES,SDECWKIN,,,,,SDECSC,,,,,,1,+SDECLEN)
+18 if '+SDECAPPTID
QUIT
+19 SET SDECNOTE=$PIECE(SDECNOD,U,4)
+20 IF SDECNOTE]""
DO SDECWP(SDECAPPTID,SDECNOTE)
+21 QUIT
STRIP(SDECZ) ;Replace control characters with spaces
+1 NEW SDECI
+2 FOR SDECI=1:1:$LENGTH(SDECZ)
IF (32>$ASCII($EXTRACT(SDECZ,SDECI)))
SET SDECZ=$EXTRACT(SDECZ,1,SDECI-1)_" "_$EXTRACT(SDECZ,SDECI+1,999)
+3 QUIT SDECZ
ERR(SDECI,SDECERR,DFN,LOCK) ;Error processing SD,740
+1 SET DFN=$GET(DFN)
+2 SET SDECI=SDECI+1
+3 SET SDECERR=$TRANSLATE(SDECERR,"^","~")
+4 SET ^TMP("SDEC07",$JOB,SDECI)=$GET(SDECAPPTID,0)_"^"_SDECERR_$CHAR(30)
+5 SET SDECI=SDECI+1
+6 SET ^TMP("SDEC07",$JOB,SDECI)=$CHAR(31)
+7 IF $GET(LOCK)=1
LOCK -^DPT(DFN)
+8 IF $GET(LOCK)=2
LOCK -^DPT(DFN)
+9 IF +$GET(SDECAPPTID)
LOCK -^SDEC(409.84,SDECAPPTID)
+10 QUIT
ETRAP ;EP Error trap entry
+1 DO ^%ZTER
+2 IF '$DATA(SDECI)
NEW SDECI
SET SDECI=999999
+3 SET SDECI=SDECI+1
+4 DO ERR(SDECI,"SDEC07 Error")
+5 QUIT
ERROR ;
+1 DO ERR1("Error")
+2 QUIT
ERR1(SDECERR) ;Error processing
+1 SET SDECI=SDECI+1
+2 SET ^TMP("SDEC07",$JOB,SDECI)=SDECERR_$CHAR(30)
+3 SET SDECI=SDECI+1
+4 SET ^TMP("SDEC07",$JOB,SDECI)=$CHAR(31)
+5 QUIT
