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

SDESCREATEAPPT.m

Go to the documentation of this file.
SDESCREATEAPPT  ;ALB/BLB,MGD,DJS,ANU,BLB,TJB,BLB/TJB,LAB - CREATE APPOINTMENT RPC; AUG 3, 2023
 ;;5.3;Scheduling;**814,823,826,827,828,842,843,846,847,851,853,869,877**;Aug 13, 1993;Build 14
 ;;Per VHA Directive 6402, this routine should not be modified
 ;
 ;----------------- ----------------- ----------
 ;
 Q
 ;
 ; create appt in file 409.84. Called from wrapper level SDESCRTAPPTWRAP. See SDESCRTAPPTWRAP for required inputs.
 ;
VALIDATE(ERRORS,ARY84,ARY44) ; Validate input
 N MAXDAYS,SDECRNOD,RESOURCED,ENCOUNTER,REQUESTIEN,SDCONERR,SDAPPTSTARTDATE,IEN,TYPEIEN,TIMEDIFF
 ;
 ; appointment Start Date and Time
 S ARY84("SDAPPTSTARTDTTM")=$G(ARY84("SDAPPTSTARTDTTM"),"")
 I ARY84("SDAPPTSTARTDTTM")="" D ERRLOG^SDESJSON(.ERRORS,165) Q
 I $P($G(ARY84("SDAPPTSTARTDTTM")),"T",2)="" D ERRLOG^SDESJSON(.ERRORS,166) Q  ;ISSUE INVALID ERROR MESSAGE IF NO TIME ENTERED
 S ARY84("SDAPPTSTARTDTTM")=$$ISOTFM^SDAMUTDT(ARY84("SDAPPTSTARTDTTM"),ARY84("CLINICIEN"))
 I ARY84("SDAPPTSTARTDTTM")=-1 D ERRLOG^SDESJSON(.ERRORS,166) Q
 ;
 ; appointment End Date and Time
 S ARY84("SDAPPTENDDTTM")=$G(ARY84("SDAPPTENDDTTM"),"")
 I ARY84("SDAPPTENDDTTM")="" D ERRLOG^SDESJSON(.ERRORS,167) Q
 I $P($G(ARY84("SDAPPTENDDTTM")),"T",2)="" D ERRLOG^SDESJSON(.ERRORS,168) Q  ;ISSUE INVALID ERROR MESSAGE IF NO TIME ENTERED
 S ARY84("SDAPPTENDDTTM")=$$ISOTFM^SDAMUTDT(ARY84("SDAPPTENDDTTM"),ARY84("CLINICIEN"))
 I ARY84("SDAPPTENDDTTM")=-1!($L(ARY84("SDAPPTENDDTTM"),".")=1) D ERRLOG^SDESJSON(.ERRORS,168) Q
 I ARY84("SDAPPTSTARTDTTM")>ARY84("SDAPPTENDDTTM") D ERRLOG^SDESJSON(.ERRORS,13) Q
 ;
 ; patient DFN
 S ARY84("DFN")=$G(ARY84("DFN"),"")
 I ARY84("DFN")="" D ERRLOG^SDESJSON(.ERRORS,1) Q
 I ARY84("DFN")'="",'$D(^DPT(+ARY84("DFN"),0)) D ERRLOG^SDESJSON(.ERRORS,2) Q
 ;
 ; clinic IEN
 S ARY84("CLINICIEN")=$G(ARY84("CLINICIEN"),"")
 I ARY84("CLINICIEN")="" D ERRLOG^SDESJSON(.ERRORS,18) Q
 I '$D(^SC(ARY84("CLINICIEN"),0)) D ERRLOG^SDESJSON(.ERRORS,19) Q
 ;
 ; resource
 N RESOURCE,SDTYP,MATCH
 S ARY84("SDRESOURCE")=$G(ARY84("SDRESOURCE"),"")
 I +ARY84("SDRESOURCE"),'$D(^SDEC(409.831,ARY84("SDRESOURCE"),0)) D ERRLOG^SDESJSON(.ERRORS,70) Q
 I 'ARY84("SDRESOURCE") D
 .S MATCH=0
 .S RESOURCE="" F  S RESOURCE=$O(^SDEC(409.831,"ALOC",ARY84("CLINICIEN"),RESOURCE)) Q:RESOURCE'>0!(MATCH>0)  D
 ..S SDTYP=$$GET1^DIQ(409.831,RESOURCE_",",.012,"I")
 ..Q:$P(SDTYP,";",2)'="SC("
 ..S ARY84("SDRESOURCE")=RESOURCE
 ..S MATCH=1
 ;
 I $$GET1^DIQ(409.831,$G(ARY84("SDRESOURCE")),.04,"I")'=$G(ARY84("CLINICIEN")) D ERRLOG^SDESJSON(.ERRORS,366) Q
 ;
 ; max days in future allowed to schedule in clinic
 I $D(^SC(ARY84("CLINICIEN"),"SDP")) D
 .S MAXDAYS=$$GET1^DIQ(44,ARY84("CLINICIEN"),2002)
 .I MAXDAYS="" S MAXDAYS=390
 I ARY84("SDAPPTSTARTDTTM")>$$FMADD^XLFDT($$NOW^XLFDT(),MAXDAYS) D ERRLOG^SDESJSON(.ERRORS,177) Q
 ;
 ; access Type ID
 N TODAY
 S ARY84("WALKIN")=$G(ARY84("WALKIN"),"")
 I ARY84("WALKIN")'="",ARY84("WALKIN")'="y",ARY84("WALKIN")'="n" D ERRLOG^SDESJSON(.ERRORS,178) Q
 S TODAY=$$NOW^XLFDT(),TODAY=$P(TODAY,"."),ARY84("SDAPPTSTARTDATE")=$P(ARY84("SDAPPTSTARTDTTM"),".")   ;Check only the date
 ; added check for walkin - otherwise can't make appointment that isn't today - BLB - added new error code - DJS
 I ARY84("WALKIN")="y",ARY84("SDAPPTSTARTDATE")<TODAY!(ARY84("SDAPPTSTARTDATE")>TODAY) D ERRLOG^SDESJSON(.ERRORS,166) Q
 ;
 ; desired Date of Appointment
 S ARY84("SDESIREDTTM")=$G(ARY84("SDESIREDTTM"),"")
 I ARY84("SDESIREDTTM")'="" S ARY84("SDESIREDTTM")=$$ISOTFM^SDAMUTDT(ARY84("SDESIREDTTM"),ARY84("CLINICIEN"))
 I ARY84("SDESIREDTTM")=-1 D ERRLOG^SDESJSON(.ERRORS,58) Q
 ;
 ; appt request type
 S ARY84("SDREQTYPE")=$G(ARY84("SDREQTYPE"),"")
 I ARY84("SDREQTYPE")="" D ERRLOG^SDESJSON(.ERRORS,60) Q
 I ";E;R;C;A;"'[(";"_$P(ARY84("SDREQTYPE"),"|",1)_";") D ERRLOG^SDESJSON(.ERRORS,61) Q
 I +$P(ARY84("SDREQTYPE"),"|",2)=0 D ERRLOG^SDESJSON(.ERRORS,61) Q
 I ARY84("SDREQTYPE")'="" D
 .I $P(ARY84("SDREQTYPE"),"|",1)="E" I '$D(^SDWL(409.3,+$P(ARY84("SDREQTYPE"),"|",2),0)) S ARY84("SDREQTYPE")=""
 .I $P(ARY84("SDREQTYPE"),"|",1)="R" I '$D(^SD(403.5,+$P(ARY84("SDREQTYPE"),"|",2),0)) S ARY84("SDREQTYPE")=""
 .I $P(ARY84("SDREQTYPE"),"|",1)="C" I '$D(^GMR(123,+$P(ARY84("SDREQTYPE"),"|",2),0)) S ARY84("SDREQTYPE")=""
 .I $P(ARY84("SDREQTYPE"),"|",1)="A" I '$D(^SDEC(409.85,+$P(ARY84("SDREQTYPE"),"|",2),0)) S ARY84("SDREQTYPE")=""
 I ARY84("SDREQTYPE")="" D ERRLOG^SDESJSON(.ERRORS,61) Q
 ;ANU
 I $P(ARY84("SDREQTYPE"),"|",1)="A",$$GET1^DIQ(409.85,+$P(ARY84("SDREQTYPE"),"|",2)_",",23,"I")="C" D ERRLOG^SDESJSON(.ERRORS,433) Q
 I $P(ARY84("SDREQTYPE"),"|",1)="E",$$GET1^DIQ(409.3,+$P(ARY84("SDREQTYPE"),"|",2)_",",23,"I")="C" D ERRLOG^SDESJSON(.ERRORS,433) Q
 S SDCONERR=0
 I $P(ARY84("SDREQTYPE"),"|",1)="C" D
 .I $$GET1^DIQ(123,+$P(ARY84("SDREQTYPE"),"|",2)_",",8,"E")'="PENDING",$$GET1^DIQ(123,+$P(ARY84("SDREQTYPE"),"|",2)_",",8,"E")'="ACTIVE" S SDCONERR=1
 ;
 S IEN=$P(ARY84("SDREQTYPE"),"|",2)
 I $P(ARY84("SDREQTYPE"),"|")="A" D
 .I ARY84("DFN")'=$$GET1^DIQ(409.85,IEN,.01,"I") D ERRLOG^SDESJSON(.ERRORS,447) Q
 I $P(ARY84("SDREQTYPE"),"|")="R" D
 .I ARY84("DFN")'=$$GET1^DIQ(403.5,IEN,.01,"I") D ERRLOG^SDESJSON(.ERRORS,447) Q
 I $P(ARY84("SDREQTYPE"),"|")="C" D
 .I ARY84("DFN")'=$$GET1^DIQ(123,IEN,.02,"I") D ERRLOG^SDESJSON(.ERRORS,447) Q
 ;
 I SDCONERR D ERRLOG^SDESJSON(.ERRORS,433) Q
 ;
 ; note
 S ARY84("SDNOTE")=$G(ARY84("SDNOTE"),"") S:ARY84("SDNOTE")'="" ARY84("SDNOTE")=$TR($E(ARY84("SDNOTE"),1,150),"^"," ")
 ;
 ; appointment Type
 I '$G(ARY84("SDAPPTYPE")),'$L($G(ARY84("SDAPPTNAME"))) D ERRLOG^SDESJSON(.ERRORS,306) Q
 ;
 I '$G(ARY84("SDAPPTNAME")),$G(ARY84("SDAPPTYPE")) D
 .I '$D(^SD(409.1,ARY84("SDAPPTYPE"),0)) D ERRLOG^SDESJSON(.ERRORS,180) Q
 ;
 I $L($G(ARY84("SDAPPTNAME"))) D
 .I '$D(^SD(409.1,"B",$G(ARY84("SDAPPTNAME")))) D ERRLOG^SDESJSON(.ERRORS,446) Q
 .S TYPEIEN=0
 .S ARY84("SDAPPTYPE")=$O(^SD(409.1,"B",ARY84("SDAPPTNAME"),TYPEIEN))
 ;
 ; patient Status
 S ARY84("SDPATIENTSTATUS")=$G(ARY84("SDPATIENTSTATUS"))
 I ARY84("SDPATIENTSTATUS")="" D
 .I $P(ARY84("SDREQTYPE"),"|",1)="A" S ARY84("SDPATIENTSTATUS")=$$GET1^DIQ(409.3,$P(ARY84("SDREQTYPE"),"|",2)_",",.02,"I")
 S ARY84("SDPATIENTSTATUS")=$S(ARY84("SDPATIENTSTATUS")="N":"N",ARY84("SDPATIENTSTATUS")="NEW":"N",ARY84("SDPATIENTSTATUS")="E":"E",ARY84("SDPATIENTSTATUS")="ESTABLISHED":"E",1:"")
 ;
 ; appt length - if passed in, must be 5-120
 S ARY44("SDAPPTLENGTH")=$G(ARY84("SDAPPTLENGTH"),"")
 I ARY84("SDAPPTLENGTH")="" D ERRLOG^SDESJSON(.ERRORS,115) Q
 I ARY84("SDAPPTLENGTH")'="",((+ARY84("SDAPPTLENGTH")<5)!(+ARY84("SDAPPTLENGTH")>120)) D ERRLOG^SDESJSON(.ERRORS,116) Q
 S TIMEDIFF=$$FMDIFF^XLFDT(ARY84("SDAPPTENDDTTM"),ARY84("SDAPPTSTARTDTTM"),2)/60
 I TIMEDIFF'=ARY84("SDAPPTLENGTH") D ERRLOG^SDESJSON(.ERRORS,116) Q
 ;
 ; validate EAS
 S ARY84("SDEAS")=$G(ARY84("SDEAS"),"")
 I $L(ARY84("SDEAS")) S ARY84("SDEAS")=$$EASVALIDATE^SDESUTIL(ARY84("SDEAS"))
 I $G(ARY84("SDEAS"))=-1 D ERRLOG^SDESJSON(.ERRORS,142) Q
 ;
 ; validate provider
 I $G(ARY84("SDPROVIEN")),'$D(^VA(200,+$G(ARY84("SDPROVIEN")),0)) D ERRLOG^SDESJSON(.ERRORS,54) Q
 I '$G(ARY84("SDPROVIEN")) S ARY84("SDPROVIEN")=$$GETPROVIDER(ARY84("CLINICIEN"),$P(ARY84("SDREQTYPE"),"|",1),$P(ARY84("SDREQTYPE"),"|",2))
 ;
 S ARY84("SDEXTERNALID")=$G(ARY84("SDEXTERNALID"),"")
 ;
 ;validate MTRC flag (optional)
 S ARY84("SDMRTC")=$G(ARY84("SDMRTC"),"")
 S ARY84("SDMRTC")=$$UP^XLFSTR($G(ARY84("SDMRTC")))
 S ARY84("SDMRTC")=$S(ARY84("SDMRTC")="TRUE":1,1:0)
 ;
 ;validate parent
 I ARY84("SDPARENT")'="" D
 .I '$D(^SDEC(409.85,ARY84("SDPARENT"))) D ERRLOG^SDESJSON(.ERRORS,179) Q
 .;ANU
 .I $$GET1^DIQ(409.85,ARY84("SDPARENT")_",",23,"I")="C" D ERRLOG^SDESJSON(.ERRORS,433) Q
 ;
 ;validate service connected
 S ARY84("SDSERVCONNPERC")=$G(ARY84("SDSERVCONNPERC"),"")
 I ARY84("SDSERVCONNPERC")'="" S:(+ARY84("SDSERVCONNPERC")<0)!(+ARY84("SDSERVCONNPERC")>100) ARY84("SDSERVCONNPERC")=""
 S ARY84("SDSERVCONN")=$G(ARY84("SDSERVCONN"),"")
 S ARY84("SDSERVCONN")=$S(ARY84("SDSERVCONN")=0:0,ARY84("SDSERVCONN")="NO":0,ARY84("SDSERVCONN")=1:1,ARY84("SDSERVCONN")="YES":1,1:"")
 ;
 Q
 ;
GETPROVIDER(CLINICIEN,REQUESTTYPE,REQUESTIEN) ;
 N DEFAULTPROVIEN,PROVIDERIEN
 ;
 I REQUESTTYPE="R" Q $$GET1^DIQ(403.54,$$GET1^DIQ(403.5,REQUESTIEN,4,"I"),.01,"I")
 ;
 S PROVIDERIEN=0,DEFAULTPROVIEN=""
 F  S PROVIDERIEN=$O(^SC(CLINICIEN,"PR",PROVIDERIEN)) Q:'PROVIDERIEN!($G(DEFAULTPROVIEN))  D
 .I $$GET1^DIQ(44.1,PROVIDERIEN_","_CLINICIEN_",",.02,"I") S DEFAULTPROVIEN=$$GET1^DIQ(44.1,PROVIDERIEN_","_CLINICIEN_",",.01,"I")
 ;
 Q DEFAULTPROVIEN
 ;
CREATE(ARY84FDA,ARY84) ;
 N SDREQTYPE
 S SDREQTYPE=ARY84("SDREQTYPE")
 S ARY84FDA(409.84,"+1,",.01)=$G(ARY84("SDAPPTSTARTDTTM"))
 S ARY84FDA(409.84,"+1,",.02)=$G(ARY84("SDAPPTENDDTTM"))
 S ARY84FDA(409.84,"+1,",.05)=$G(ARY84("DFN"))
 S ARY84FDA(409.84,"+1,",.06)=$G(ARY84("SDAPPTYPE"))
 S ARY84FDA(409.84,"+1,",.07)=$G(ARY84("SDRESOURCE"))
 S ARY84FDA(409.84,"+1,",.08)=$G(DUZ)
 S ARY84FDA(409.84,"+1,",.09)=$$NOW^XLFDT
 S ARY84FDA(409.84,"+1,",.13)=$G(ARY84("WALKIN"))
 S ARY84FDA(409.84,"+1,",.16)=$G(ARY84("SDPROVIEN"))
 S ARY84FDA(409.84,"+1,",.18)=$G(ARY84("SDAPPTLENGTH"))
 S ARY84FDA(409.84,"+1,",.2)=$G(ARY84("SDESIREDTTM"))
 S ARY84FDA(409.84,"+1,",.21)=$G(ARY84("SDEXTERNALID"))
 S ARY84FDA(409.84,"+1,",.22)=$S(SDREQTYPE'="":$P(SDREQTYPE,"|",2)_";"_$S($P(SDREQTYPE,"|",1)="E":"SDWL(409.3,",$P(SDREQTYPE,"|",1)="C":"GMR(123,",$P(SDREQTYPE,"|",1)="R":"SD(403.5,",$P(SDREQTYPE,"|",1)="A":"SDEC(409.85,",1:""),1:"")
 S ARY84FDA(409.84,"+1,",.23)=$G(ARY84("SDPATIENTSTATUS"))
 S ARY84FDA(409.84,"+1,",100)=$G(ARY84("SDEAS"))
 Q
 ;
CLEANUP40984(ARY84,NEWIEN40984,APPTMSG) ;
 N REQUEST
 ;file word processing field in NOTE (409.84,1)
 K SDECMSG
 I ARY84("SDNOTE")'="" N ARR D WP^SDECUTL(.ARR,ARY84("SDNOTE")) D WP^DIE(409.84,NEWIEN40984_",",1,"","ARR","SDECMSG")
 S REQUESTIEN=$P(ARY84("SDREQTYPE"),"|",2)
 ;
 ;delete recall request if appointment made from recall
 I $P(ARY84("SDREQTYPE"),"|",1)="R" D  ; VSE-863 ;6/9/2021
 .N SDCOMM,SDRET,SDRIEN1,SDRRFTR
 .S SDRIEN1=$P(ARY84("SDREQTYPE"),"|",2)
 .S SDCOMM=$$GET1^DIQ(403.5,SDRIEN1,2.5)
 .S SDRRFTR="APPT SCHEDULED" ; "7"
 .D RECDSET^SDEC52A(.SDRET,SDRIEN1,SDRRFTR,SDCOMM)
 ;
 ; add MRTC data to parent request
 I $P(ARY84("SDREQTYPE"),"|",1)="A" D
 .D BUILDAPPTDATA^SDESEDITAPPTREQ(REQUESTIEN,$G(ARY84("SDAPPTSTARTDTTM")),$G(ARY84("CLINICIEN")),$G(ARY84("SDSERVCONNPERC")),$G(ARY84("SDSERVCONN")),$G(ARY84("SDAPPTYPE")),$G(ARY84("SDEAS")),DUZ,.APPTMSG)
 I $G(ARY84("SDPARENT")),$G(ARY84("SDMRTC")) D
 .S REQUEST("MRTC","PATIENT INDICATED DATE")=$G(ARY84("SDESIREDTTM"))
 .S REQUEST("MRTC","CHILD REQUEST")=REQUESTIEN
 .S REQUEST("MRTC","MRTC APPOINTMENT")=$G(NEWIEN40984)
 .D BUILDMRTCLINKS^SDESEDITAPPTREQ(.REQUEST,$G(ARY84("SDPARENT")))
 .D BUILDMRTCPID^SDESEDITAPPTREQ(.REQUEST,$G(ARY84("SDPARENT")))
 ;
 I $P(ARY84("SDREQTYPE"),"|",1)="C" D
 .D REQSET^SDEC07A($P($G(ARY84("SDREQTYPE")),"|",2),$G(ARY84("SDPROVIEN")),"",1,"",$G(ARY84("SDNOTE")),$G(ARY84("SDAPPTSTARTDTTM")),$G(ARY84("SDRESOURCE")),$G(ARY84("DFN")))
 .D UPDATECONSULTPID^SDES2APPTUTIL($P($G(ARY84("SDREQTYPE")),"|",2),$G(ARY84("SDESIREDTTM")),$G(ARY84("DFN")))
 ;add entry to OUTPATIENT ENCOUNTER file (#409.68)  ;alb/sat 672
 I $$NOW^XLFDT>ARY84("SDAPPTSTARTDTTM"),$$NEW^SDPCE(ARY84("SDAPPTSTARTDTTM")) D
 .S ENCOUNTER=$$GETAPT^SDVSIT2(ARY84("DFN"),ARY84("SDAPPTSTARTDTTM"),ARY84("CLINICIEN"))
 ;
 Q
 ;