Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDEC07

SDEC07.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. ;
  1. ; Reference to ^GMR(123 is supported by IA #4837
  1. Q
  1. 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. N SDAPPTYP,CKATYP
  1. N SDECERR,SDECIEN,SDECDEP,SDECI,SDECJ,SDECAPPTI,SDECDJ,SDECRESD,SDECRNOD,SDECC,SDECERR,SDECWKIN,ITYP,REQIEN
  1. N SDECNOEV,SDECDEV,SDECDERR,SDECTMP,SAVESTRT,SDAREQ0,XQOPT
  1. N %DT,X,Y,DGQUIET,OBM,RET
  1. N SDOE,DONE
  1. ;Don't execute SDEC ADD APPOINTMENT protocol
  1. S SDECNOEV=1
  1. K ^TMP("SDEC07",$J)
  1. S SDECERR=0
  1. S SDECI=0
  1. S SDECY="^TMP(""SDEC07"","_$J_")"
  1. S ^TMP("SDEC07",$J,SDECI)="I00020APPOINTMENTID^T00020ERRORID"_$C(30)
  1. S SDECI=SDECI+1
  1. S ITYP="SDEC07 Error: Invalid Appointment Type"
  1. S CKATYP=$P($G(SDAPTYP),"|",1)
  1. I ("^A^C^R^"'[("^"_CKATYP_"^")) D ERR(SDECI+1,ITYP,,0) Q
  1. S REQIEN=+$P($G(SDAPTYP),"|",2)
  1. I 'REQIEN D ERR(SDECI+1,ITYP,,0) Q
  1. I CKATYP="E" I '$D(^SDWL(409.3,REQIEN,0)) D ERR(SDECI+1,ITYP,,0) Q
  1. I CKATYP="R" I '$D(^SD(403.5,REQIEN,0)) D ERR(SDECI+1,ITYP,,0) Q
  1. I CKATYP="C" I '$D(^GMR(123,REQIEN,0)) D ERR(SDECI+1,ITYP,,0) Q
  1. I CKATYP="A" I '$D(^SDEC(409.85,REQIEN,0)) D ERR(SDECI+1,ITYP,,0) Q
  1. 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
  1. S SAVESTRT=SDECSTART
  1. S ITYP="SDEC07 Error: The patient on the appointment request and the subsequent appointment must match."
  1. I CKATYP="R" I DFN'=$$GET1^DIQ(403.5,REQIEN,.01,"I") D ERR(SDECI+1,ITYP,,0) Q
  1. I CKATYP="C" I DFN'=$$GET1^DIQ(123,REQIEN,.02,"I") D ERR(SDECI+1,ITYP,,0) Q
  1. I CKATYP="A" I DFN'=$$GET1^DIQ(409.85,REQIEN,.01,"I") D ERR(SDECI+1,ITYP,,0) Q
  1. ;
  1. S SDECSTART=$$NETTOFM^SDECDATE(SDECSTART,"Y")
  1. I SDECSTART=-1 D ERR(SDECI+1,"SDEC07 Error: Invalid Start Time",,0) Q
  1. S SDECEND=$$NETTOFM^SDECDATE(SDECEND,"Y")
  1. I SDECEND=-1 D ERR(SDECI+1,"SDEC07 Error: Invalid End Time",,0) Q
  1. I $L(SDECEND,".")=1 D ERR(SDECI+1,"SDEC07 Error: Invalid End Time",,0) Q
  1. I SDECSTART>SDECEND S SDECTMP=SDECEND,SDECEND=SDECSTART,SDECSTART=SDECTMP
  1. S DFN=$G(DFN)
  1. I DFN="" D ERR(SDECI+1,"SDEC07: Patient ID required.",,0) Q
  1. I '$D(^DPT(DFN,0)) D ERR(SDECI+1,"SDEC07 Error: Invalid Patient ID",,0) Q
  1. L +^DPT(DFN):3 I '$T D ERR(SDECI+1,"Patient is being edited. Try again later.",,0) Q
  1. D OP^XQCHK
  1. N POP
  1. S POP=0
  1. S:(CKATYP="A")&($P($G(XQOPT),U)'="SD RECEIVE OR") POP=$$ORDERLOCKCHECK^SDEC07C($P(SDAREQ0,"^",5),$P(SDAPTYP,"|",2),.SDECI,DFN)
  1. Q:POP
  1. ; Reject if another appointment scheduled at same time.
  1. 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
  1. ;Validate Resource
  1. S SDECERR=0 K SDECRESD
  1. S SDECRES=$G(SDECRES) I SDECRES="" D ERR(SDECI+1,"SDEC07 Error: Invalid Resource ID",DFN,1) Q
  1. I +SDECRES,'$D(^SDEC(409.831,SDECRES,0)) D ERR(SDECI+1,"SDEC07 Error: Invalid Resource ID",DFN,1) Q
  1. I '+SDECRES,'$D(^SDEC(409.831,"B",SDECRES)) D ERR(SDECI+1,"SDEC07 Error: Invalid Resource ID",DFN,1) Q
  1. S SDECRESD=$S(+SDECRES:+SDECRES,1:$O(^SDEC(409.831,"B",SDECRES,0)))
  1. S SDECRNOD=$G(^SDEC(409.831,SDECRESD,0))
  1. I SDECRNOD="" D ERR(SDECI+1,"SDEC07 Error: Unable to add appointment -- invalid Resource entry.",DFN,1) Q
  1. N PTR44,MAXDAYS S PTR44=$P(SDECRNOD,"^",4),MAXDAYS=390
  1. I +PTR44,$D(^SC(PTR44,"SDP")) S MAXDAYS=$P(^("SDP"),"^",2) S:MAXDAYS="" MAXDAYS=390
  1. I SDECSTART>$$FMADD^XLFDT($$NOW^XLFDT(),MAXDAYS) D ERR(SDECI+1,"Appointment date too far in the future",DFN,1) Q
  1. S SDECWKIN=0
  1. S SDECATID=$G(SDECATID)
  1. I SDECATID="WALKIN" S SDECWKIN=1
  1. I SDECATID'?.N&(SDECATID'="WALKIN") S SDECATID=""
  1. S SDECLEN=$G(SDECLEN)
  1. ;validate MTRC flag (optional)
  1. S SDMRTC=$$UP^XLFSTR($G(SDMRTC))
  1. S SDMRTC=$S(SDMRTC="TRUE":1,1:0)
  1. ;validate desired date of appt (optional)
  1. S SDDDT=$G(SDDDT)
  1. I SDDDT'="" S %DT="" S X=$P(SDDDT,"@",1) D ^%DT S SDDDT=Y I Y=-1 S SDDDT=""
  1. I SDDDT="",SDECATID'="WALKIN" S SDDDT=$P(SDECSTART,".",1)
  1. ;validate requested by
  1. S SDREQBY=$$UP^XLFSTR($G(SDREQBY))
  1. I SDREQBY'="" S SDREQBY=$S(SDREQBY="PROVIDER":1,SDREQBY="PATIENT":2,1:0)
  1. ;validate lab date/time (optional)
  1. S SDLAB=$G(SDLAB)
  1. I SDLAB'="" S %DT="T" S X=SDLAB D ^%DT S SDLAB=Y I Y=-1 S SDLAB=""
  1. ;validate EKG date/time (optional)
  1. S SDEKG=$G(SDEKG)
  1. I SDEKG'="" S %DT="T" S X=SDEKG D ^%DT S SDEKG=Y I Y=-1 S SDEKG=""
  1. ;validate XRAY date/time (optional)
  1. S SDXRAY=$G(SDXRAY)
  1. I SDXRAY'="" S %DT="T" S X=SDXRAY D ^%DT S SDXRAY=Y I Y=-1 S SDXRAY=""
  1. S SDID=$G(SDID)
  1. ;validate clini101
  1. S SDCL=$G(SDCL)
  1. I SDCL'="" I '$D(^SC(SDCL,0)) S SDCL=""
  1. ;clinic ID ;support for single HOSPITAL LOCATION in SDEC RESOURCE
  1. I SDCL="" S SDCL=$$GET1^DIQ(409.831,SDECRESD_",",.04,"I")
  1. S OVB=+$G(OVB)
  1. 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
  1. ;validate appt request type (required)
  1. I SDCL="" D
  1. .S:$P(SDAPTYP,"|",1)="E" SDCL=$$GET1^DIQ(409.3,$P(SDAPTYP,"|",2)_",",13.2,"I")
  1. .S:$P(SDAPTYP,"|",1)="R" SDCL=$$GET1^DIQ(403.5,$P(SDAPTYP,"|",2)_",",4.5,"I")
  1. .;ICR 4837 ICR states 'Zero node read into variable'
  1. .S:$P(SDAPTYP,"|",1)="C" SDCL=$P($G(^GMR(123,+$P(SDAPTYP,"|",2),0)),U,4)
  1. .S:$P(SDAPTYP,"|",1)="A" SDCL=$$GET1^DIQ(409.85,$P(SDAPTYP,"|",2)_",",8,"I")
  1. I SDCL="" D ERR(SDECI+1,"SDEC07 Error: Invalid clinic ID.",DFN,1) Q
  1. I $$INACTIVE^SDEC32(SDCL) D ERR(SDECI+1,"SDEC07 Error: "_$$GET1^DIQ(44,SDCL_",",.01)_" is an inactive clinic.",DFN,1) Q
  1. ;Reject if consult is not active or pending.
  1. 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
  1. . 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
  1. ;validate provider
  1. S DONE=0
  1. I $P(SDAPTYP,"|",1)'="R" D
  1. . I $G(PROVIEN),'$D(^VA(200,+$G(PROVIEN),0)) D ERR(SDECI+1,"SDEC07 Error: Invalid provider ID.",DFN,1) S DONE=1
  1. . I $G(PROVIEN)="" S PROVIEN=$$GETPROVIDER^SDESCREATEAPPT(SDCL,$P(SDAPTYP,"|",1),$P(SDAPTYP,"|",2))
  1. I $P(SDAPTYP,"|",1)="R" D
  1. . 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
  1. Q:DONE
  1. ;validate service connected
  1. S SDSVCPR=$G(SDSVCPR)
  1. I SDSVCPR'="" S:(+SDSVCPR<0)!(+SDSVCPR>100) SDSVCPR=""
  1. S SDSVCP=$G(SDSVCP)
  1. S SDSVCP=$S(SDSVCP=0:0,SDSVCP="NO":0,SDSVCP=1:1,SDSVCP="YES":1,1:"")
  1. ;validate note - only use 1st 150 characters
  1. S SDECNOTE=$$CTRL^XMXUTIL1($G(SDECNOTE)) S:SDECNOTE'="" SDECNOTE=$TR($E(SDECNOTE,1,150),"^"," ")
  1. ;validate APPTYPE
  1. S APPTYPE=$G(APPTYPE) I APPTYPE'="",'$D(^SD(409.1,+APPTYPE,0)) S APPTYPE=""
  1. ;validate Patient Status (EESTAT)
  1. S EESTAT=$G(EESTAT)
  1. I EESTAT="" D
  1. .I $P(SDAPTYP,"|",1)="E" S EESTAT=$$GET1^DIQ(409.3,$P(SDAPTYP,"|",2)_",",27,"I")
  1. .I $P(SDAPTYP,"|",1)="A" S EESTAT=$$GET1^DIQ(409.3,$P(SDAPTYP,"|",2)_",",.02,"I")
  1. S EESTAT=$S(EESTAT="N":"N",EESTAT="NEW":"N",EESTAT="E":"E",EESTAT="ESTABLISHED":"E",1:"")
  1. ;validate OVB (overbook)
  1. S OVB=+$G(OVB)
  1. I 'OVB D
  1. .D OVBOOK^SDEC07A(.RET,SDCL,SDECSTART,SDECRES)
  1. D
  1. .S SDAPPTYP=+APPTYPE
  1. .I 'SDAPPTYP D
  1. ..I $P(SDAPTYP,"|",1)="E" S SDAPPTYP=$$GET1^DIQ(409.3,+$P(SDAPTYP,"|",2)_",",8.7,"I")
  1. ..I $P(SDAPTYP,"|",1)="A" S SDAPPTYP=$$GET1^DIQ(409.85,+$P(SDAPTYP,"|",2)_",",8.7,"I")
  1. ..I $P(SDAPTYP,"|",1)="C",+APPTYPE S SDAPPTYP=+APPTYPE
  1. .S:'SDAPPTYP SDAPPTYP=$O(^SD(409.1,"B","REGULAR",0))
  1. S EAS=$TR($G(EAS),"^"," ")
  1. I $L(EAS) S EAS=$$EASVALIDATE^SDESUTIL(EAS)
  1. I EAS=-1 D ERR(SDECI+1,"SDEC07 Error: Invalid EAS Tracking Number",,0) Q
  1. S SDECAPPTID=$$SDECADD(SDECSTART,SDECEND,DFN,SDECRESD,SDECATID,SDDDT,SDID,SDAPTYP,PROVIEN,SDCL,SDECNOTE,SAVESTRT,SDECRES,SDAPPTYP,EESTAT,1,+SDECLEN,EAS)
  1. I 'SDECAPPTID D ERR(SDECI+1,"SDEC07 Error: Unable to add appointment to SDEC APPOINTMENT file.",DFN,2) Q
  1. ;Lock SDEC node & save appt
  1. 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
  1. S SDECDEV=""
  1. I SDECATID="WALKIN",$G(SDECCR),$G(SDECDEV)'="" S DGQUIET=1 D WISD^SDECRT(DFN,$P(SDECSTART,"."),"",SDECDEV)
  1. I SDECNOTE]"" D SDECWP(SDECAPPTID,SDECNOTE)
  1. I +SDCL,$D(^SC(SDCL,0)) D I +SDECERR D ERR(SDECI+1,$P(SDECERR,U,2),DFN,2)
  1. . S SDECC("PAT")=DFN
  1. . S SDECC("CLN")=SDCL
  1. . S SDECC("TYP")=$S(+SDECWKIN:4,SDAPPTYP=1:1,1:3)
  1. . S SDECC("COL")=$S(SDAPPTYP=7:1,1:"")
  1. . S SDECC("APT")=SDAPPTYP
  1. . S SDECC("ADT")=SDECSTART
  1. . S SDECC("LEN")=SDECLEN
  1. . S SDECC("OI")=$E($G(SDECNOTE),1,150)
  1. . S SDECC("OI")=$TR(SDECC("OI"),";"," ")
  1. . S SDECC("OI")=$$STRIP(SDECC("OI"))
  1. . S SDECC("RES")=SDECRESD
  1. . S SDECC("USR")=DUZ
  1. . S SDECC("MTR")=$G(SDMRTC)
  1. . S SDECC("DDT")=SDDDT
  1. . S SDECC("REQ")=SDREQBY
  1. . S SDECC("LAB")=SDLAB
  1. . S SDECC("XRA")=SDXRAY
  1. . S SDECC("EKG")=SDEKG
  1. . S SDECC("OVB")=$S(OVB=1:1,1:0)
  1. . S SDECC("ELG")=SDEL
  1. . S:$P(SDAPTYP,"|",1)="C" SDECC("CON")=$P(SDAPTYP,"|",2)
  1. . S SDECERR=$$MAKE^SDEC07B(.SDECC)
  1. . Q:SDECERR
  1. . D AVUPDT^SDEC07C(SDCL,SDECSTART,SDECLEN)
  1. . Q
  1. I $P(SDAPTYP,"|",1)="E" D EWL^SDEC07A($P(SDAPTYP,"|",2),SDECSTART,SDCL,SDSVCPR,SDSVCP,,SDAPPTYP)
  1. I $P(SDAPTYP,"|",1)="A" D
  1. .D UPDATE^SDECAR2($P(SDAPTYP,"|",2),SDECSTART,SDCL,SDSVCPR,SDSVCP,,SDAPPTYP,EAS)
  1. .I $G(SDMRTC),$G(SDPARENT) D AR433^SDECAR2(SDPARENT,SDECAPPTID_"~"_$P(SDAPTYP,"|",2))
  1. .D:$G(SDPARENT) AR438^SDECAR2($P(SDAPTYP,"|",2),SDPARENT)
  1. N SDT S SDT=SDECSTART
  1. I $$NOW^XLFDT>SDT,$$NEW^SDPCE(SDT) D
  1. .N SDCOED
  1. .S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
  1. L -^SDEC(409.84,SDECAPPTID)
  1. L -^DPT(DFN)
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC07",$J,SDECI)=SDECAPPTID_"^"_$G(SDECDERR)_$C(30)
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC07",$J,SDECI)=$C(31)
  1. Q
  1. ;ADD SDEC APPT ENTRY
  1. SDECADD(SDECSTART,SDECEND,DFN,SDECRESD,SDECATID,SDDDT,SDID,SDAPTYP,PROVIEN,SDCL,SDECNOTE,SAVESTRT,SDECRES,SDAPPTYP,EESTAT,SDF,SDECLEN,EAS) ;
  1. N SDIEN,SDECAPPTID,SDECIEN,SDECMSG,SL,X,SDDFN,FDA,ERR,REQIEN
  1. S SDECSTART=$G(SDECSTART)
  1. S SAVESTRT=$G(SAVESTRT),SDECRES=$G(SDECRES)
  1. S DFN=$G(DFN),SDDFN=DFN
  1. S SDECRESD=$G(SDECRESD)
  1. S SDECATID=$G(SDECATID)
  1. S SDDDT=$G(SDDDT)
  1. S SDID=$G(SDID)
  1. S SDAPTYP=$G(SDAPTYP)
  1. S SDAPPTYP=$G(SDAPPTYP)
  1. S PROVIEN=$G(PROVIEN)
  1. S SDCL=$G(SDCL)
  1. S SDECEND=$G(SDECEND)
  1. I $P(SDAPTYP,"|",1)="R" D
  1. .S PROVIEN=$$GET1^DIQ(403.54,PROVIEN,.01,"I")
  1. S SDECLEN=$G(SDECLEN)
  1. 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
  1. I SDECLEN="",SDECEND'="" S SDECLEN=$$FMDIFF^XLFDT(SDECEND,SDECSTART,2)\60 ;no length
  1. I SDECLEN'="",SDECEND="" S SDECEND=$$FMADD^XLFDT(SDECSTART,,,+SDECLEN) ;no end date/time
  1. S SDECNOTE=$G(SDECNOTE)
  1. S SDF=$G(SDF,0)
  1. S EAS=$G(EAS)
  1. I PROVIEN="" S PROVIEN=$$GET1^DIQ(44,SDCL_",",16,"I")
  1. S SDIEN=$$APPTGET^SDECUTL(DFN,SDECSTART,SDCL)
  1. S SDIEN=$S(SDIEN'="":SDIEN_",",1:"+1,") K FDA
  1. S FDA(409.84,SDIEN,.01)=SDECSTART
  1. S FDA(409.84,SDIEN,.02)=SDECEND
  1. S FDA(409.84,SDIEN,.03)="@"
  1. S FDA(409.84,SDIEN,.04)="@"
  1. S FDA(409.84,SDIEN,.05)=DFN
  1. S FDA(409.84,SDIEN,.06)=$S(+SDAPPTYP:SDAPPTYP,1:"@")
  1. S FDA(409.84,SDIEN,.07)=SDECRESD
  1. S FDA(409.84,SDIEN,.08)=$G(DUZ)
  1. S FDA(409.84,SDIEN,.09)=$$NOW^XLFDT
  1. S FDA(409.84,SDIEN,.1)="@"
  1. S FDA(409.84,SDIEN,.101)="@"
  1. S FDA(409.84,SDIEN,.102)="@"
  1. S FDA(409.84,SDIEN,.11)="@"
  1. S FDA(409.84,SDIEN,.12)="@"
  1. S FDA(409.84,SDIEN,.121)="@"
  1. S FDA(409.84,SDIEN,.122)="@"
  1. S FDA(409.84,SDIEN,.13)=$S(SDECATID="WALKIN":"y",1:"@")
  1. S FDA(409.84,SDIEN,.14)="@"
  1. S FDA(409.84,SDIEN,.16)=$S(PROVIEN'="":PROVIEN,1:"@")
  1. S FDA(409.84,SDIEN,.17)="@"
  1. S FDA(409.84,SDIEN,.18)=$S($G(SDECLEN)'="":SDECLEN,1:"@")
  1. S FDA(409.84,SDIEN,.2)=SDDDT
  1. S FDA(409.84,SDIEN,.21)=$S($G(SDID)'="":SDID,1:"@")
  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:"@")
  1. S FDA(409.84,SDIEN,.23)=$S($G(EESTAT)'="":EESTAT,1:"@")
  1. S:EAS'="" FDA(409.84,SDIEN,100)=EAS
  1. K SDECIEN,SDECMSG
  1. D UPDATE^DIE("","FDA","SDECIEN","SDECMSG")
  1. I $P(SDAPTYP,"|",1)="A"!($P(SDAPTYP,"|",1)="R") D
  1. .S REQIEN=$P(SDAPTYP,"|",2)
  1. .I $$LASTPIDCHECK^SDECAR2(REQIEN,SDDDT) D
  1. ..K FDA S FDA(409.854,"+1,"_REQIEN_",",.01)=$$NOW^XLFDT
  1. ..S FDA(409.854,"+1,"_REQIEN_",",1)=SDDDT
  1. ..S FDA(409.854,"+1,"_REQIEN_",",2)=$$GET1^DIQ(200,DUZ,.01,"E")
  1. ..D UPDATE^DIE(,"FDA",,"ERR") K FDA
  1. S SDECAPPTID=$S(SDIEN'="+1,":+SDIEN,1:+$G(SDECIEN(1)))
  1. K SDECMSG
  1. I SDECNOTE="" D WP^DIE(409.84,$S(+$G(SDECAPPTID):SDECAPPTID_",",1:SDIEN_","),1,"","@","SDECMSG")
  1. I SDECNOTE'="" D
  1. . S SDECNOTE=$$CTRL^XMXUTIL1(SDECNOTE)
  1. . N ARR D WP^SDECUTL(.ARR,SDECNOTE) D WP^DIE(409.84,$S(+$G(SDECAPPTID):SDECAPPTID_",",1:SDIEN_","),1,"","ARR","SDECMSG")
  1. . ; 409.84 NOTE AUDIT multiple
  1. . N NAFDA,NAIENS
  1. . S NAIENS=$S(+$G(SDECAPPTID):SDECAPPTID_",",1:SDIEN_",")
  1. . S NAFDA(409.847,"+1,"_NAIENS,.01)=$$NOW^XLFDT
  1. . S NAFDA(409.847,"+1,"_NAIENS,1)=DUZ
  1. . S NAFDA(409.847,"+1,"_NAIENS,2)=SDECNOTE
  1. . D UPDATE^DIE("","NAFDA") K NAFDA
  1. I SDECAPPTID'="" D
  1. .I $P(SDAPTYP,"|",1)="C",SDF D
  1. ..D CONSULTPID^SDEC07PID(SDAPTYP,DFN,PROVIEN,SAVESTRT,SDDDT,SDDFN,SDECNOTE,SDECRES)
  1. .I $P(SDAPTYP,"|",1)="R" D ; VSE-863 ;6/9/2021
  1. .. N SDCOMM,SDRET,SDRIEN1,SDRRFTR
  1. .. S SDRIEN1=$P(SDAPTYP,"|",2)
  1. .. S SDCOMM=$$GET1^DIQ(403.5,SDRIEN1,2.5)
  1. .. S SDRRFTR="APPT SCHEDULED" ; "7"
  1. .. D RECDSET^SDEC52A(.SDRET,SDRIEN1,SDRRFTR,SDCOMM)
  1. I $G(SDECAPPTID) D SETMISSIONELIG^SDESMISSIONELG(SDECAPPTID)
  1. Q SDECAPPTID
  1. CONSPIDCHECK(SDRIEN1,SDDDT) ;
  1. N CHIEN,CHSIEN,OLDPID
  1. S CHIEN=$O(^SDEC(409.87,"B",SDRIEN1,0))
  1. S CHSIEN=$O(^SDEC(409.87,CHIEN,1,9999999),-1)
  1. S OLDPID=$$GET1^DIQ(409.871,CHSIEN_","_CHIEN_",",1,"I")
  1. I OLDPID'=$G(SDDDT) Q 1
  1. Q 0
  1. SDECWP(SDECAPPTID,SDECNOTE) ;
  1. ;Add WP field
  1. I SDECNOTE]"" S SDECNOTE(.5)=SDECNOTE,SDECNOTE=""
  1. I $D(SDECNOTE(0)) S SDECNOTE(.5)=SDECNOTE(0) K SDECNOTE(0)
  1. I $D(SDECNOTE(.5)) D
  1. . D WP^DIE(409.84,SDECAPPTID_",",1,"","SDECNOTE","SDECMSG")
  1. Q
  1. ADDEVT(DFN,SDECSTART,SDECSC,SDCLA) ;EP
  1. ;Called by SDEC ADD APPOINTMENT protocol
  1. ;SDECSC=IEN of clinic in ^SC
  1. ;SDCLA=IEN for ^SC(SDECSC,"S",SDECSTART,1,SDCLA)
  1. N SDECNOD,SDECLEN,SDECAPPTID,SDECNODP,SDECWKIN,SDECRES
  1. Q:+$G(SDECNOEV)
  1. I $D(^SDEC(409.831,"ALOC",SDECSC)) S SDECRES=$O(^SDEC(409.831,"ALOC",SDECSC,0))
  1. Q:'+$G(SDECRES)
  1. S SDECNOD=$G(^SC(SDECSC,"S",SDECSTART,1,SDCLA,0))
  1. Q:SDECNOD=""
  1. S SDECNODP=$G(^DPT(DFN,"S",SDECSTART,0))
  1. S SDECWKIN=""
  1. ;Purpose of Visit field of DPT Appointment subfile
  1. S:$P(SDECNODP,U,7)=4 SDECWKIN="WALKIN"
  1. S SDECLEN=$P(SDECNOD,U,2)
  1. Q:'+SDECLEN
  1. S SDECEND=$$FMADD^XLFDT(SDECSTART,0,0,SDECLEN,0)
  1. S SDECAPPTID=$$SDECADD(SDECSTART,SDECEND,DFN,SDECRES,SDECWKIN,,,,,SDECSC,,,,,,1,+SDECLEN)
  1. Q:'+SDECAPPTID
  1. S SDECNOTE=$P(SDECNOD,U,4)
  1. I SDECNOTE]"" D SDECWP(SDECAPPTID,SDECNOTE)
  1. Q
  1. STRIP(SDECZ) ;Replace control characters with spaces
  1. N SDECI
  1. F SDECI=1:1:$L(SDECZ) I (32>$A($E(SDECZ,SDECI))) S SDECZ=$E(SDECZ,1,SDECI-1)_" "_$E(SDECZ,SDECI+1,999)
  1. Q SDECZ
  1. ERR(SDECI,SDECERR,DFN,LOCK) ;Error processing
  1. S DFN=$G(DFN)
  1. S SDECI=SDECI+1
  1. S SDECERR=$TR(SDECERR,"^","~")
  1. S ^TMP("SDEC07",$J,SDECI)=$G(SDECAPPTID,0)_"^"_SDECERR_$C(30)
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC07",$J,SDECI)=$C(31)
  1. I $G(LOCK)=1 L -^DPT(DFN)
  1. I $G(LOCK)=2 L -^DPT(DFN)
  1. I +$G(SDECAPPTID) L -^SDEC(409.84,SDECAPPTID)
  1. Q
  1. ETRAP ;EP Error trap entry
  1. D ^%ZTER
  1. I '$D(SDECI) N SDECI S SDECI=999999
  1. S SDECI=SDECI+1
  1. D ERR(SDECI,"SDEC07 Error")
  1. Q
  1. ERROR ;
  1. D ERR1("Error")
  1. Q
  1. ERR1(SDECERR) ;Error processing
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC07",$J,SDECI)=SDECERR_$C(30)
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC07",$J,SDECI)=$C(31)
  1. Q