- SDEC07 ;ALB/SAT,PC,KML,MGD,LAB,TJB/BLB,TJB,JAS - ADD NEW APPOINTMENT ; NOV 22,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,895**;Aug 13, 1993;Build 11
- ;;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
- ;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=$$CTRL^XMXUTIL1($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)
- .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)
- 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) ;
- 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
- . S SDECNOTE=$$CTRL^XMXUTIL1(SDECNOTE)
- . 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)
- 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
- 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 16122 printed Jan 18, 2025@03:51:05 Page 2
- SDEC07 ;ALB/SAT,PC,KML,MGD,LAB,TJB/BLB,TJB,JAS - ADD NEW APPOINTMENT ; NOV 22,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,895**;Aug 13, 1993;Build 11
- +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 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=$$CTRL^XMXUTIL1($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 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 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) ;
- +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 SET SDECNOTE=$$CTRL^XMXUTIL1(SDECNOTE)
- +66 NEW ARR
- DO WP^SDECUTL(.ARR,SDECNOTE)
- DO WP^DIE(409.84,$SELECT(+$GET(SDECAPPTID):SDECAPPTID_",",1:SDIEN_","),1,"","ARR","SDECMSG")
- +67 ; 409.84 NOTE AUDIT multiple
- +68 NEW NAFDA,NAIENS
- +69 SET NAIENS=$SELECT(+$GET(SDECAPPTID):SDECAPPTID_",",1:SDIEN_",")
- +70 SET NAFDA(409.847,"+1,"_NAIENS,.01)=$$NOW^XLFDT
- +71 SET NAFDA(409.847,"+1,"_NAIENS,1)=DUZ
- +72 SET NAFDA(409.847,"+1,"_NAIENS,2)=SDECNOTE
- +73 DO UPDATE^DIE("","NAFDA")
- KILL NAFDA
- End DoDot:1
- +74 IF SDECAPPTID'=""
- Begin DoDot:1
- +75 IF $PIECE(SDAPTYP,"|",1)="C"
- IF SDF
- Begin DoDot:2
- +76 DO CONSULTPID^SDEC07PID(SDAPTYP,DFN,PROVIEN,SAVESTRT,SDDDT,SDDFN,SDECNOTE,SDECRES)
- End DoDot:2
- +77 ; VSE-863 ;6/9/2021
- IF $PIECE(SDAPTYP,"|",1)="R"
- Begin DoDot:2
- +78 NEW SDCOMM,SDRET,SDRIEN1,SDRRFTR
- +79 SET SDRIEN1=$PIECE(SDAPTYP,"|",2)
- +80 SET SDCOMM=$$GET1^DIQ(403.5,SDRIEN1,2.5)
- +81 ; "7"
- SET SDRRFTR="APPT SCHEDULED"
- +82 DO RECDSET^SDEC52A(.SDRET,SDRIEN1,SDRRFTR,SDCOMM)
- End DoDot:2
- End DoDot:1
- +83 IF $GET(SDECAPPTID)
- DO SETMISSIONELIG^SDESMISSIONELG(SDECAPPTID)
- +84 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 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
- +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