SDES2APPTUTIL ;ALB/BLB,TJB/ANU/BLB/LAB,BLB,LAB,BWF,JAS,JAS - SDES2 CREATE APPOINTMENT UTILITIES ;MAY 7, 2025
;;5.3;Scheduling;**866,871,875,877,878,880,881,890,893,905,907**;Aug 13, 1993;Build 5
;;Per VHA Directive 6402, this routine should not be modified
;---------------------------------------------------------------
Q
;
APPTREQ(SDCONTEXT,APPOINTMENT,APPTIEN,APPTMSG) ; called only on create of appointment
N STARTDATETIME,CLINICIEN,REQUESTIEN,REQUESTTYPE,SDUSER
S REQUESTIEN=$P($G(APPOINTMENT("REQUEST TYPE")),"|",2)
S REQUESTTYPE=$P($G(APPOINTMENT("REQUEST TYPE")),"|")
;
S STARTDATETIME=$G(APPOINTMENT("START DATE TIME")),CLINICIEN=$G(APPOINTMENT("CLINIC IEN"))
D ADDPIDHISTORY^SDESCREATEAPPREQ($P($G(APPOINTMENT("REQUEST TYPE")),"|",2),$G(APPOINTMENT("PATIENT INDICATED DATE")))
;
D BUILDAPPTDATA^SDESEDITAPPTREQ(REQUESTIEN,STARTDATETIME,CLINICIEN,$G(APPOINTMENT("SERVICE CONNECTED PERCENTAGE")),$G(APPOINTMENT("SERVICE CONNECTED")),$G(APPOINTMENT("APPOINTMENT TYPE")),$G(SDCONTEXT("ACHERON AUDIT ID")),DUZ,.APPTMSG)
I $G(APPOINTMENT("MRTC PARENT")),$G(APPOINTMENT("MRTC")) D
.D MRTCCHILD($G(APPOINTMENT("PATIENT INDICATED DATE")),REQUESTIEN,APPTIEN,$G(APPOINTMENT("MRTC PARENT")))
Q
;
RECALL(RECALLRETURN,SDCONTEXT,RECALL,REQUESTIEN) ;
S RECALL("RECALL IEN")=REQUESTIEN
S RECALL("DELETE REASON")=7
D DISPRECALL^SDES2DISPRECALL(.RECALLRETURN,.SDCONTEXT,.RECALL)
Q
;
CONSULT(APPOINTMENT,APPTIEN44,USERID) ;
N FDA,REQUESTIEN,PROVIDERIEN,NOTE,STARTDATETIME,RESOURCEIEN,DFN,CLINICIEN,NETSTARTDT,GMRCDUZ
;
S REQUESTIEN=$P($G(APPOINTMENT("REQUEST TYPE")),"|",2)
S PROVIDERIEN=$G(APPOINTMENT("PROVIDER IEN"))
S NOTE=$G(APPOINTMENT("NOTE"))
S STARTDATETIME=$G(APPOINTMENT("START DATE TIME"))
S NETSTARTDT=$$FMTONET^SDECDATE(STARTDATETIME)
S RESOURCEIEN=$G(APPOINTMENT("RESOURCE IEN"))
S DFN=$G(APPOINTMENT("DFN"))
S CLINICIEN=$G(APPOINTMENT("CLINIC IEN"))
D REQSET(REQUESTIEN,USERID,"SCHEDULED","",$TR($E(NOTE,1,150),"^"," "),STARTDATETIME,CLINICIEN,DFN)
;
S FDA(44.003,APPTIEN44_","_STARTDATETIME_","_CLINICIEN_",",688)=REQUESTIEN
D UPDATE^DIE("","FDA") K FDA
;
D UPDATECONSULTPID(REQUESTIEN,$G(APPOINTMENT("PATIENT INDICATED DATE")),DFN,.USERID)
Q
;
REQSET(REQUESTIEN,USERID,ACTION,CANCELLEDBY,NOTE,STARTDATETIME,CLINICIEN,DFN) ;
N %DT,X,SD,TMPYCLNC
;
I $$GET1^DIQ(123,REQUESTIEN_",",8,"E")="DISCONTINUED"!($$GET1^DIQ(123,REQUESTIEN_",",8,"E")="COMPLETE") Q
;
I ACTION="SCHEDULED" D
.D EDITCS^SDCNSLT(STARTDATETIME,NOTE,CLINICIEN_U_$$GET1^DIQ(44,CLINICIEN,.01,"E"),REQUESTIEN)
;
I ACTION="CANCELLED" D
.D SDECCAN^SDCNSLT(REQUESTIEN,$$GET1^DIQ(123,REQUESTIEN,.02,"I"),STARTDATETIME,CLINICIEN,CANCELLEDBY,$$GET44APPTIEN^SDES2NOSHOW(CLINICIEN,STARTDATETIME,DFN),NOTE)
Q
;
UPDATECONSULTPID(CONSULTIEN,PID,DFN,USERIEN) ;
N CONSULTPIDIEN,CONSULTFDA,CONSULTSUBFDA,TOPLEVELIEN
;
I '$D(^SDEC(409.87,"B",CONSULTIEN)) D
.S CONSULTFDA(409.87,"+1,",.01)=CONSULTIEN
.S CONSULTFDA(409.87,"+1,",.02)=DFN
.D UPDATE^DIE("","CONSULTFDA","TOPLEVELIEN") K CONSULTFDA
.;
.S CONSULTSUBFDA(409.871,"+1,"_TOPLEVELIEN(1)_",",.01)=$$NOW^XLFDT
.S CONSULTSUBFDA(409.871,"+1,"_TOPLEVELIEN(1)_",",1)=PID
.S CONSULTSUBFDA(409.871,"+1,"_TOPLEVELIEN(1)_",",2)=$S($G(USERIEN):USERIEN,1:DUZ)
.D UPDATE^DIE("","CONSULTSUBFDA") K CONSULTSUBFDA
;
; file consult pid history subfile only
S CONSULTPIDIEN=$O(^SDEC(409.87,"B",CONSULTIEN,0))
I $D(^SDEC(409.87,"B",CONSULTIEN)) D
.I $$CONSPIDCHECK^SDEC07(CONSULTIEN,PID) D
..S CONSULTSUBFDA(409.871,"+1,"_CONSULTPIDIEN_",",.01)=$$NOW^XLFDT
..S CONSULTSUBFDA(409.871,"+1,"_CONSULTPIDIEN_",",1)=PID
..S CONSULTSUBFDA(409.871,"+1,"_CONSULTPIDIEN_",",2)=$S($G(USERIEN):USERIEN,1:DUZ)
..D UPDATE^DIE("","CONSULTSUBFDA") K CONSULTSUBFDA
Q
;
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
;
ENCOUNTERS(APPOINTMENT,ENCOUNTER) ;
I $$NOW^XLFDT>$G(APPOINTMENT("START DATE TIME")),$$NEW^SDPCE($G(APPOINTMENT("START DATE TIME"))) D
.S ENCOUNTER=$$GETAPT^SDVSIT2($G(APPOINTMENT("DFN")),$G(APPOINTMENT("START DATE TIME")),$G(APPOINTMENT("CLINIC IEN")))
Q
;
MAKE(DFN,STARTDATETIME,CLINICIEN) ;
D MAKE^SDAMEVT(DFN,STARTDATETIME,CLINICIEN,$$SCIEN^SDECU2(DFN,CLINICIEN,STARTDATETIME),2)
Q
;
GETRESOURCE(ERRORS,APPOINTMENT,CLINICIEN) ;
N RESOURCE,MATCH
;
I '$G(APPOINTMENT("RESOURCE IEN")) D
.S RESOURCE=0,MATCH=0
.F S RESOURCE=$O(^SDEC(409.831,"ALOC",CLINICIEN,RESOURCE)) Q:RESOURCE'>0!(MATCH>0) D
..I $$GET1^DIQ(409.831,RESOURCE_",",.012,"E")'="CLINIC" Q
..S APPOINTMENT("RESOURCE IEN")=RESOURCE,MATCH=1
;
I $$GET1^DIQ(409.831,$G(APPOINTMENT("RESOURCE IEN")),.04,"I")'=$G(CLINICIEN) D ERRLOG^SDESJSON(.ERRORS,366) Q
Q
;
GETPROVIDER(APPOINTMENT,CLINICIEN,PROVIDER,REQUESTTYPE,REQUESTIEN) ;
N DEFAULTPROVIEN,PROVIDERIEN
;
I $L($G(PROVIDER)) Q
;
I REQUESTTYPE="R" D Q
.S APPOINTMENT("PROVIDER IEN")=$$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")
S APPOINTMENT("PROVIDER IEN")=DEFAULTPROVIEN
;
Q
;
MRTCCHILD(PID,REQUESTIEN,APPTIEN,PARENT) ;
N REQUEST
S REQUEST("MRTC","PATIENT INDICATED DATE")=$G(APPOINTMENT("PATIENT INDICATED DATE"))
S REQUEST("MRTC","CHILD REQUEST")=REQUESTIEN
S REQUEST("MRTC","MRTC APPOINTMENT")=$G(APPTIEN)
D BUILDMRTCLINKS^SDESEDITAPPTREQ(.REQUEST,$G(APPOINTMENT("MRTC PARENT")))
D BUILDMRTCPID^SDESEDITAPPTREQ(.REQUEST,$G(APPOINTMENT("MRTC PARENT")))
Q
;
CLEANCMMTS(COMMENTS) ;
S COMMENTS=$$CTRL^XMXUTIL1(COMMENTS)
S COMMENTS=$TR(COMMENTS,"^"," ")
D FORMATCMMTS(.COMMENTS)
Q COMMENTS
;
FORMATCMMTS(COMMENTS) ;
N CHARNUM,END,LEADING,TRAILING
Q:'$L(COMMENTS)
S (LEADING,TRAILING)=1,END=0
F CHARNUM=1:1:$L(COMMENTS) Q:END D
. I $E(COMMENTS,1)'=" " S LEADING=0
. I $E(COMMENTS,1)=" " S COMMENTS=$E(COMMENTS,2,$L(COMMENTS))
. I $E(COMMENTS,$L(COMMENTS))'=" " S TRAILING=0
. I $E(COMMENTS,$L(COMMENTS))=" " S COMMENTS=$E(COMMENTS,1,($L(COMMENTS)-1))
. I 'LEADING,'TRAILING S END=1
Q
;
STOREREQUESTCOMM(REQUESTIEN) ;
N SUBIEN,PATIENTCOMMENTS
;
I $D(^SDEC(409.85,REQUESTIEN,"PATCOM",0)) D
.S SUBIEN=0
.F S SUBIEN=$O(^SDEC(409.85,REQUESTIEN,"PATCOM",SUBIEN)) Q:'SUBIEN D
..S PATIENTCOMMENTS(SUBIEN)=$$GET1^DIQ(409.855,SUBIEN_","_REQUESTIEN_",",.01,"E")
D WP^DIE(409.84,APPTIEN_",",4,"","PATIENTCOMMENTS")
Q
;
STORENOTE(APPTIEN,NOTE,APPTNOTES) ;
I $L(NOTE) D
.D WP^SDECUTL(.APPTNOTES,NOTE)
.D WP^DIE(409.84,APPTIEN_",",1,"","APPTNOTES")
Q
;
REQUESTTYPE(ERRORS,APPOINTMENTS,REQUESTTYPE,REQUESTIEN,DFN) ;
I '$L($G(APPOINTMENT("REQUEST TYPE"))) D ERRLOG^SDESJSON(.ERRORS,60) Q
;
I REQUESTTYPE'="A",REQUESTTYPE'="R",REQUESTTYPE'="C" D ERRLOG^SDESJSON(.ERRORS,61) Q
;
I '$G(REQUESTIEN) D ERRLOG^SDESJSON(.ERRORS,61) Q
;
I REQUESTTYPE="R",'$D(^SD(403.5,REQUESTIEN,0)) D ERRLOG^SDESJSON(.ERRORS,61) Q
I REQUESTTYPE="C",'$D(^GMR(123,REQUESTIEN,0)) D ERRLOG^SDESJSON(.ERRORS,61) Q
I REQUESTTYPE="A",'$D(^SDEC(409.85,REQUESTIEN,0)) D ERRLOG^SDESJSON(.ERRORS,61) Q
;
I REQUESTTYPE="A",$$GET1^DIQ(409.85,$G(REQUESTIEN),23,"I")="C" D ERRLOG^SDESJSON(.ERRORS,433) Q
;
I REQUESTTYPE="C" D
.I $$GET1^DIQ(123,REQUESTIEN_",",8,"E")'="PENDING",$$GET1^DIQ(123,+REQUESTIEN_",",8,"E")'="ACTIVE" D ERRLOG^SDESJSON(.ERRORS,433) Q
;
I REQUESTTYPE="A" D
.I DFN'=$$GET1^DIQ(409.85,REQUESTIEN,.01,"I") D ERRLOG^SDESJSON(.ERRORS,447) Q
I REQUESTTYPE="R" D
.I DFN'=$$GET1^DIQ(403.5,REQUESTIEN,.01,"I") D ERRLOG^SDESJSON(.ERRORS,447) Q
I REQUESTTYPE="C" D
.I DFN'=$$GET1^DIQ(123,REQUESTIEN,.02,"I") D ERRLOG^SDESJSON(.ERRORS,447)
Q
;
GETAPPTTYPE(ERRORS,APPOINTMENT,TYPE,TYPENAME) ;
I '$G(TYPE),'$L($G(TYPENAME)) D ERRLOG^SDESJSON(.ERRORS,306) Q
;
I $G(TYPE),$D(^SD(409.1,TYPE,0)) Q
;
I $L($G(TYPENAME)),$D(^SD(409.1,"B",TYPENAME)) S APPOINTMENT("APPOINTMENT TYPE")=$$FIND1^DIC(409.1,"","X",TYPENAME,"B") Q
;
D ERRLOG^SDESJSON(.ERRORS,180)
Q
;
APPTIN44EXISTS(DFN,CLINIC,DATE) ;
N SUBIEN,FOUND
;
S SUBIEN=0,FOUND=0
F S SUBIEN=$O(^SC(CLINIC,"S",DATE,1,SUBIEN)) Q:'SUBIEN!($G(FOUND)=1) D
.I $$GET1^DIQ(44.003,SUBIEN_","_DATE_","_CLINIC_",",310)="CANCELLED" Q ;cancelled
.I $$GET1^DIQ(44.003,SUBIEN_","_DATE_","_CLINIC_",",.01,"I")=DFN S FOUND=1 Q ; record exists
I $G(FOUND) Q 1
Q 0
;
APPTINDIFFTZ(DFN,DATETIME,CLINICIEN) ;
N EXISTINGAPPTCLIN,EXISTINGDATETIME,APPTIEN,FOUND
;
S FOUND=0,APPTIEN=0
F S APPTIEN=$O(^SDEC(409.84,"CPAT",DFN,APPTIEN)) Q:'APPTIEN!($G(FOUND)=1) D
.I $$GET1^DIQ(409.84,APPTIEN,.12,"I") Q
.S EXISTINGAPPTCLIN=$$GET1^DIQ(409.831,$$GET1^DIQ(409.84,APPTIEN,.07,"I"),.04,"I")
.S EXISTINGDATETIME=$$FMTISO^SDAMUTDT($$GET1^DIQ(409.84,APPTIEN,.01,"I"),EXISTINGAPPTCLIN)
.I $$ISOTFM^SDAMUTDT(EXISTINGDATETIME,CLINICIEN)=DATETIME S FOUND=1
Q FOUND
;
DELETECANRECORD(DFN,DATETIME,CLINICIEN) ;
N SUBIEN,FOUND,FDA,FDAERR
;
S SUBIEN=0,FOUND=0
F S SUBIEN=$O(^SC(CLINICIEN,"S",DATETIME,1,SUBIEN)) Q:'SUBIEN!(FOUND=1) D
.I $$GET1^DIQ(44.003,SUBIEN_","_DATETIME_","_CLINICIEN_",",.01,"I")=DFN D
..I $$GET1^DIQ(44.003,SUBIEN_","_DATETIME_","_CLINICIEN_",",310)'="CANCELLED" D
...S FOUND=1
...S FDA(2.98,DATETIME_","_DFN_",",.01)="@"
...D FILE^DIE(,"FDA","FDAERR") K FDA
;
DELETERECORD(ARRAYDELETE) ;
N DELETEFDA,FILENUMBER,IENS,ERR
;
S FILENUMBER=0
F S FILENUMBER=$O(ARRAYDELETE(FILENUMBER)) Q:'FILENUMBER D
.S IENS=ARRAYDELETE(FILENUMBER)
.S DELETEFDA(FILENUMBER,IENS,.01)="@"
.D FILE^DIE(,"DELETEFDA","ERR") K DELETEFDA
Q
;
ORDERCHECKLOCK(ERRORS,REQTYPE,DFN) ;
N FOUND,REQUESTIEN,ORDERID
;
S FOUND=0
S REQUESTIEN=$P($G(REQTYPE),"|",2)
S REQTYPE=$$GET1^DIQ(409.85,REQUESTIEN,4,"I")
I REQTYPE="RTC" D
.S ORDERID=$$GET1^DIQ(409.85,REQUESTIEN,46,"I")
.I '+$G(ORDERID) Q
.I $D(^XTMP("ORLK-"_ORDERID)) D ERRLOG^SDESJSON(.ERRORS,188) S FOUND=1
Q FOUND
;
GETPID(APPOINTMENT,PID,REQUESTTYPE,REQUESTIEN) ;
I $L($G(PID)) Q
;
I REQUESTTYPE="A" S PID=$$GET1^DIQ(409.85,REQUESTIEN,22,"I")
I REQUESTTYPE="R" S PID=$$GET1^DIQ(403.5,REQUESTIEN,5,"I")
;
I REQUESTTYPE="C",$$GET1^DIQ(123,REQUESTIEN,17,"I")'="" S PID=$$GET1^DIQ(123,REQUESTIEN,17,"I")
I REQUESTTYPE="C",PID="" S PID=$$GET1^DIQ(123,REQUESTIEN,.01,"I")
;
S APPOINTMENT("PATIENT INDICATED DATE")=$G(PID)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2APPTUTIL 10699 printed Aug 26, 2025@23:09:24 Page 2
SDES2APPTUTIL ;ALB/BLB,TJB/ANU/BLB/LAB,BLB,LAB,BWF,JAS,JAS - SDES2 CREATE APPOINTMENT UTILITIES ;MAY 7, 2025
+1 ;;5.3;Scheduling;**866,871,875,877,878,880,881,890,893,905,907**;Aug 13, 1993;Build 5
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;---------------------------------------------------------------
+4 QUIT
+5 ;
APPTREQ(SDCONTEXT,APPOINTMENT,APPTIEN,APPTMSG) ; called only on create of appointment
+1 NEW STARTDATETIME,CLINICIEN,REQUESTIEN,REQUESTTYPE,SDUSER
+2 SET REQUESTIEN=$PIECE($GET(APPOINTMENT("REQUEST TYPE")),"|",2)
+3 SET REQUESTTYPE=$PIECE($GET(APPOINTMENT("REQUEST TYPE")),"|")
+4 ;
+5 SET STARTDATETIME=$GET(APPOINTMENT("START DATE TIME"))
SET CLINICIEN=$GET(APPOINTMENT("CLINIC IEN"))
+6 DO ADDPIDHISTORY^SDESCREATEAPPREQ($PIECE($GET(APPOINTMENT("REQUEST TYPE")),"|",2),$GET(APPOINTMENT("PATIENT INDICATED DATE")))
+7 ;
+8 DO BUILDAPPTDATA^SDESEDITAPPTREQ(REQUESTIEN,STARTDATETIME,CLINICIEN,$GET(APPOINTMENT("SERVICE CONNECTED PERCENTAGE")),$GET(APPOINTMENT("SERVICE CONNECTED")),$GET(APPOINTMENT("APPOINTMENT TYPE")),$GET(SDCONTEXT("ACHERON AUDIT ID")),DUZ,.APPTMSG)
+9 IF $GET(APPOINTMENT("MRTC PARENT"))
IF $GET(APPOINTMENT("MRTC"))
Begin DoDot:1
+10 DO MRTCCHILD($GET(APPOINTMENT("PATIENT INDICATED DATE")),REQUESTIEN,APPTIEN,$GET(APPOINTMENT("MRTC PARENT")))
End DoDot:1
+11 QUIT
+12 ;
RECALL(RECALLRETURN,SDCONTEXT,RECALL,REQUESTIEN) ;
+1 SET RECALL("RECALL IEN")=REQUESTIEN
+2 SET RECALL("DELETE REASON")=7
+3 DO DISPRECALL^SDES2DISPRECALL(.RECALLRETURN,.SDCONTEXT,.RECALL)
+4 QUIT
+5 ;
CONSULT(APPOINTMENT,APPTIEN44,USERID) ;
+1 NEW FDA,REQUESTIEN,PROVIDERIEN,NOTE,STARTDATETIME,RESOURCEIEN,DFN,CLINICIEN,NETSTARTDT,GMRCDUZ
+2 ;
+3 SET REQUESTIEN=$PIECE($GET(APPOINTMENT("REQUEST TYPE")),"|",2)
+4 SET PROVIDERIEN=$GET(APPOINTMENT("PROVIDER IEN"))
+5 SET NOTE=$GET(APPOINTMENT("NOTE"))
+6 SET STARTDATETIME=$GET(APPOINTMENT("START DATE TIME"))
+7 SET NETSTARTDT=$$FMTONET^SDECDATE(STARTDATETIME)
+8 SET RESOURCEIEN=$GET(APPOINTMENT("RESOURCE IEN"))
+9 SET DFN=$GET(APPOINTMENT("DFN"))
+10 SET CLINICIEN=$GET(APPOINTMENT("CLINIC IEN"))
+11 DO REQSET(REQUESTIEN,USERID,"SCHEDULED","",$TRANSLATE($EXTRACT(NOTE,1,150),"^"," "),STARTDATETIME,CLINICIEN,DFN)
+12 ;
+13 SET FDA(44.003,APPTIEN44_","_STARTDATETIME_","_CLINICIEN_",",688)=REQUESTIEN
+14 DO UPDATE^DIE("","FDA")
KILL FDA
+15 ;
+16 DO UPDATECONSULTPID(REQUESTIEN,$GET(APPOINTMENT("PATIENT INDICATED DATE")),DFN,.USERID)
+17 QUIT
+18 ;
REQSET(REQUESTIEN,USERID,ACTION,CANCELLEDBY,NOTE,STARTDATETIME,CLINICIEN,DFN) ;
+1 NEW %DT,X,SD,TMPYCLNC
+2 ;
+3 IF $$GET1^DIQ(123,REQUESTIEN_",",8,"E")="DISCONTINUED"!($$GET1^DIQ(123,REQUESTIEN_",",8,"E")="COMPLETE")
QUIT
+4 ;
+5 IF ACTION="SCHEDULED"
Begin DoDot:1
+6 DO EDITCS^SDCNSLT(STARTDATETIME,NOTE,CLINICIEN_U_$$GET1^DIQ(44,CLINICIEN,.01,"E"),REQUESTIEN)
End DoDot:1
+7 ;
+8 IF ACTION="CANCELLED"
Begin DoDot:1
+9 DO SDECCAN^SDCNSLT(REQUESTIEN,$$GET1^DIQ(123,REQUESTIEN,.02,"I"),STARTDATETIME,CLINICIEN,CANCELLEDBY,$$GET44APPTIEN^SDES2NOSHOW(CLINICIEN,STARTDATETIME,DFN),NOTE)
End DoDot:1
+10 QUIT
+11 ;
UPDATECONSULTPID(CONSULTIEN,PID,DFN,USERIEN) ;
+1 NEW CONSULTPIDIEN,CONSULTFDA,CONSULTSUBFDA,TOPLEVELIEN
+2 ;
+3 IF '$DATA(^SDEC(409.87,"B",CONSULTIEN))
Begin DoDot:1
+4 SET CONSULTFDA(409.87,"+1,",.01)=CONSULTIEN
+5 SET CONSULTFDA(409.87,"+1,",.02)=DFN
+6 DO UPDATE^DIE("","CONSULTFDA","TOPLEVELIEN")
KILL CONSULTFDA
+7 ;
+8 SET CONSULTSUBFDA(409.871,"+1,"_TOPLEVELIEN(1)_",",.01)=$$NOW^XLFDT
+9 SET CONSULTSUBFDA(409.871,"+1,"_TOPLEVELIEN(1)_",",1)=PID
+10 SET CONSULTSUBFDA(409.871,"+1,"_TOPLEVELIEN(1)_",",2)=$SELECT($GET(USERIEN):USERIEN,1:DUZ)
+11 DO UPDATE^DIE("","CONSULTSUBFDA")
KILL CONSULTSUBFDA
End DoDot:1
+12 ;
+13 ; file consult pid history subfile only
+14 SET CONSULTPIDIEN=$ORDER(^SDEC(409.87,"B",CONSULTIEN,0))
+15 IF $DATA(^SDEC(409.87,"B",CONSULTIEN))
Begin DoDot:1
+16 IF $$CONSPIDCHECK^SDEC07(CONSULTIEN,PID)
Begin DoDot:2
+17 SET CONSULTSUBFDA(409.871,"+1,"_CONSULTPIDIEN_",",.01)=$$NOW^XLFDT
+18 SET CONSULTSUBFDA(409.871,"+1,"_CONSULTPIDIEN_",",1)=PID
+19 SET CONSULTSUBFDA(409.871,"+1,"_CONSULTPIDIEN_",",2)=$SELECT($GET(USERIEN):USERIEN,1:DUZ)
+20 DO UPDATE^DIE("","CONSULTSUBFDA")
KILL CONSULTSUBFDA
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
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
+7 ;
ENCOUNTERS(APPOINTMENT,ENCOUNTER) ;
+1 IF $$NOW^XLFDT>$G(APPOINTMENT("START DATE TIME"))
IF $$NEW^SDPCE($GET(APPOINTMENT("START DATE TIME")))
Begin DoDot:1
+2 SET ENCOUNTER=$$GETAPT^SDVSIT2($GET(APPOINTMENT("DFN")),$GET(APPOINTMENT("START DATE TIME")),$GET(APPOINTMENT("CLINIC IEN")))
End DoDot:1
+3 QUIT
+4 ;
MAKE(DFN,STARTDATETIME,CLINICIEN) ;
+1 DO MAKE^SDAMEVT(DFN,STARTDATETIME,CLINICIEN,$$SCIEN^SDECU2(DFN,CLINICIEN,STARTDATETIME),2)
+2 QUIT
+3 ;
GETRESOURCE(ERRORS,APPOINTMENT,CLINICIEN) ;
+1 NEW RESOURCE,MATCH
+2 ;
+3 IF '$GET(APPOINTMENT("RESOURCE IEN"))
Begin DoDot:1
+4 SET RESOURCE=0
SET MATCH=0
+5 FOR
SET RESOURCE=$ORDER(^SDEC(409.831,"ALOC",CLINICIEN,RESOURCE))
if RESOURCE'>0!(MATCH>0)
QUIT
Begin DoDot:2
+6 IF $$GET1^DIQ(409.831,RESOURCE_",",.012,"E")'="CLINIC"
QUIT
+7 SET APPOINTMENT("RESOURCE IEN")=RESOURCE
SET MATCH=1
End DoDot:2
End DoDot:1
+8 ;
+9 IF $$GET1^DIQ(409.831,$GET(APPOINTMENT("RESOURCE IEN")),.04,"I")'=$GET(CLINICIEN)
DO ERRLOG^SDESJSON(.ERRORS,366)
QUIT
+10 QUIT
+11 ;
GETPROVIDER(APPOINTMENT,CLINICIEN,PROVIDER,REQUESTTYPE,REQUESTIEN) ;
+1 NEW DEFAULTPROVIEN,PROVIDERIEN
+2 ;
+3 IF $LENGTH($GET(PROVIDER))
QUIT
+4 ;
+5 IF REQUESTTYPE="R"
Begin DoDot:1
+6 SET APPOINTMENT("PROVIDER IEN")=$$GET1^DIQ(403.54,$$GET1^DIQ(403.5,REQUESTIEN,4,"I"),.01,"I")
End DoDot:1
QUIT
+7 ;
+8 SET PROVIDERIEN=0
SET DEFAULTPROVIEN=""
+9 FOR
SET PROVIDERIEN=$ORDER(^SC(CLINICIEN,"PR",PROVIDERIEN))
if 'PROVIDERIEN!($GET(DEFAULTPROVIEN))
QUIT
Begin DoDot:1
+10 IF $$GET1^DIQ(44.1,PROVIDERIEN_","_CLINICIEN_",",.02,"I")
SET DEFAULTPROVIEN=$$GET1^DIQ(44.1,PROVIDERIEN_","_CLINICIEN_",",.01,"I")
End DoDot:1
+11 SET APPOINTMENT("PROVIDER IEN")=DEFAULTPROVIEN
+12 ;
+13 QUIT
+14 ;
MRTCCHILD(PID,REQUESTIEN,APPTIEN,PARENT) ;
+1 NEW REQUEST
+2 SET REQUEST("MRTC","PATIENT INDICATED DATE")=$GET(APPOINTMENT("PATIENT INDICATED DATE"))
+3 SET REQUEST("MRTC","CHILD REQUEST")=REQUESTIEN
+4 SET REQUEST("MRTC","MRTC APPOINTMENT")=$GET(APPTIEN)
+5 DO BUILDMRTCLINKS^SDESEDITAPPTREQ(.REQUEST,$GET(APPOINTMENT("MRTC PARENT")))
+6 DO BUILDMRTCPID^SDESEDITAPPTREQ(.REQUEST,$GET(APPOINTMENT("MRTC PARENT")))
+7 QUIT
+8 ;
CLEANCMMTS(COMMENTS) ;
+1 SET COMMENTS=$$CTRL^XMXUTIL1(COMMENTS)
+2 SET COMMENTS=$TRANSLATE(COMMENTS,"^"," ")
+3 DO FORMATCMMTS(.COMMENTS)
+4 QUIT COMMENTS
+5 ;
FORMATCMMTS(COMMENTS) ;
+1 NEW CHARNUM,END,LEADING,TRAILING
+2 if '$LENGTH(COMMENTS)
QUIT
+3 SET (LEADING,TRAILING)=1
SET END=0
+4 FOR CHARNUM=1:1:$LENGTH(COMMENTS)
if END
QUIT
Begin DoDot:1
+5 IF $EXTRACT(COMMENTS,1)'=" "
SET LEADING=0
+6 IF $EXTRACT(COMMENTS,1)=" "
SET COMMENTS=$EXTRACT(COMMENTS,2,$LENGTH(COMMENTS))
+7 IF $EXTRACT(COMMENTS,$LENGTH(COMMENTS))'=" "
SET TRAILING=0
+8 IF $EXTRACT(COMMENTS,$LENGTH(COMMENTS))=" "
SET COMMENTS=$EXTRACT(COMMENTS,1,($LENGTH(COMMENTS)-1))
+9 IF 'LEADING
IF 'TRAILING
SET END=1
End DoDot:1
+10 QUIT
+11 ;
STOREREQUESTCOMM(REQUESTIEN) ;
+1 NEW SUBIEN,PATIENTCOMMENTS
+2 ;
+3 IF $DATA(^SDEC(409.85,REQUESTIEN,"PATCOM",0))
Begin DoDot:1
+4 SET SUBIEN=0
+5 FOR
SET SUBIEN=$ORDER(^SDEC(409.85,REQUESTIEN,"PATCOM",SUBIEN))
if 'SUBIEN
QUIT
Begin DoDot:2
+6 SET PATIENTCOMMENTS(SUBIEN)=$$GET1^DIQ(409.855,SUBIEN_","_REQUESTIEN_",",.01,"E")
End DoDot:2
End DoDot:1
+7 DO WP^DIE(409.84,APPTIEN_",",4,"","PATIENTCOMMENTS")
+8 QUIT
+9 ;
STORENOTE(APPTIEN,NOTE,APPTNOTES) ;
+1 IF $LENGTH(NOTE)
Begin DoDot:1
+2 DO WP^SDECUTL(.APPTNOTES,NOTE)
+3 DO WP^DIE(409.84,APPTIEN_",",1,"","APPTNOTES")
End DoDot:1
+4 QUIT
+5 ;
REQUESTTYPE(ERRORS,APPOINTMENTS,REQUESTTYPE,REQUESTIEN,DFN) ;
+1 IF '$LENGTH($GET(APPOINTMENT("REQUEST TYPE")))
DO ERRLOG^SDESJSON(.ERRORS,60)
QUIT
+2 ;
+3 IF REQUESTTYPE'="A"
IF REQUESTTYPE'="R"
IF REQUESTTYPE'="C"
DO ERRLOG^SDESJSON(.ERRORS,61)
QUIT
+4 ;
+5 IF '$GET(REQUESTIEN)
DO ERRLOG^SDESJSON(.ERRORS,61)
QUIT
+6 ;
+7 IF REQUESTTYPE="R"
IF '$DATA(^SD(403.5,REQUESTIEN,0))
DO ERRLOG^SDESJSON(.ERRORS,61)
QUIT
+8 IF REQUESTTYPE="C"
IF '$DATA(^GMR(123,REQUESTIEN,0))
DO ERRLOG^SDESJSON(.ERRORS,61)
QUIT
+9 IF REQUESTTYPE="A"
IF '$DATA(^SDEC(409.85,REQUESTIEN,0))
DO ERRLOG^SDESJSON(.ERRORS,61)
QUIT
+10 ;
+11 IF REQUESTTYPE="A"
IF $$GET1^DIQ(409.85,$GET(REQUESTIEN),23,"I")="C"
DO ERRLOG^SDESJSON(.ERRORS,433)
QUIT
+12 ;
+13 IF REQUESTTYPE="C"
Begin DoDot:1
+14 IF $$GET1^DIQ(123,REQUESTIEN_",",8,"E")'="PENDING"
IF $$GET1^DIQ(123,+REQUESTIEN_",",8,"E")'="ACTIVE"
DO ERRLOG^SDESJSON(.ERRORS,433)
QUIT
End DoDot:1
+15 ;
+16 IF REQUESTTYPE="A"
Begin DoDot:1
+17 IF DFN'=$$GET1^DIQ(409.85,REQUESTIEN,.01,"I")
DO ERRLOG^SDESJSON(.ERRORS,447)
QUIT
End DoDot:1
+18 IF REQUESTTYPE="R"
Begin DoDot:1
+19 IF DFN'=$$GET1^DIQ(403.5,REQUESTIEN,.01,"I")
DO ERRLOG^SDESJSON(.ERRORS,447)
QUIT
End DoDot:1
+20 IF REQUESTTYPE="C"
Begin DoDot:1
+21 IF DFN'=$$GET1^DIQ(123,REQUESTIEN,.02,"I")
DO ERRLOG^SDESJSON(.ERRORS,447)
End DoDot:1
+22 QUIT
+23 ;
GETAPPTTYPE(ERRORS,APPOINTMENT,TYPE,TYPENAME) ;
+1 IF '$GET(TYPE)
IF '$LENGTH($GET(TYPENAME))
DO ERRLOG^SDESJSON(.ERRORS,306)
QUIT
+2 ;
+3 IF $GET(TYPE)
IF $DATA(^SD(409.1,TYPE,0))
QUIT
+4 ;
+5 IF $LENGTH($GET(TYPENAME))
IF $DATA(^SD(409.1,"B",TYPENAME))
SET APPOINTMENT("APPOINTMENT TYPE")=$$FIND1^DIC(409.1,"","X",TYPENAME,"B")
QUIT
+6 ;
+7 DO ERRLOG^SDESJSON(.ERRORS,180)
+8 QUIT
+9 ;
APPTIN44EXISTS(DFN,CLINIC,DATE) ;
+1 NEW SUBIEN,FOUND
+2 ;
+3 SET SUBIEN=0
SET FOUND=0
+4 FOR
SET SUBIEN=$ORDER(^SC(CLINIC,"S",DATE,1,SUBIEN))
if 'SUBIEN!($GET(FOUND)=1)
QUIT
Begin DoDot:1
+5 ;cancelled
IF $$GET1^DIQ(44.003,SUBIEN_","_DATE_","_CLINIC_",",310)="CANCELLED"
QUIT
+6 ; record exists
IF $$GET1^DIQ(44.003,SUBIEN_","_DATE_","_CLINIC_",",.01,"I")=DFN
SET FOUND=1
QUIT
End DoDot:1
+7 IF $GET(FOUND)
QUIT 1
+8 QUIT 0
+9 ;
APPTINDIFFTZ(DFN,DATETIME,CLINICIEN) ;
+1 NEW EXISTINGAPPTCLIN,EXISTINGDATETIME,APPTIEN,FOUND
+2 ;
+3 SET FOUND=0
SET APPTIEN=0
+4 FOR
SET APPTIEN=$ORDER(^SDEC(409.84,"CPAT",DFN,APPTIEN))
if 'APPTIEN!($GET(FOUND)=1)
QUIT
Begin DoDot:1
+5 IF $$GET1^DIQ(409.84,APPTIEN,.12,"I")
QUIT
+6 SET EXISTINGAPPTCLIN=$$GET1^DIQ(409.831,$$GET1^DIQ(409.84,APPTIEN,.07,"I"),.04,"I")
+7 SET EXISTINGDATETIME=$$FMTISO^SDAMUTDT($$GET1^DIQ(409.84,APPTIEN,.01,"I"),EXISTINGAPPTCLIN)
+8 IF $$ISOTFM^SDAMUTDT(EXISTINGDATETIME,CLINICIEN)=DATETIME
SET FOUND=1
End DoDot:1
+9 QUIT FOUND
+10 ;
DELETECANRECORD(DFN,DATETIME,CLINICIEN) ;
+1 NEW SUBIEN,FOUND,FDA,FDAERR
+2 ;
+3 SET SUBIEN=0
SET FOUND=0
+4 FOR
SET SUBIEN=$ORDER(^SC(CLINICIEN,"S",DATETIME,1,SUBIEN))
if 'SUBIEN!(FOUND=1)
QUIT
Begin DoDot:1
+5 IF $$GET1^DIQ(44.003,SUBIEN_","_DATETIME_","_CLINICIEN_",",.01,"I")=DFN
Begin DoDot:2
+6 IF $$GET1^DIQ(44.003,SUBIEN_","_DATETIME_","_CLINICIEN_",",310)'="CANCELLED"
Begin DoDot:3
+7 SET FOUND=1
+8 SET FDA(2.98,DATETIME_","_DFN_",",.01)="@"
+9 DO FILE^DIE(,"FDA","FDAERR")
KILL FDA
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
DELETERECORD(ARRAYDELETE) ;
+1 NEW DELETEFDA,FILENUMBER,IENS,ERR
+2 ;
+3 SET FILENUMBER=0
+4 FOR
SET FILENUMBER=$ORDER(ARRAYDELETE(FILENUMBER))
if 'FILENUMBER
QUIT
Begin DoDot:1
+5 SET IENS=ARRAYDELETE(FILENUMBER)
+6 SET DELETEFDA(FILENUMBER,IENS,.01)="@"
+7 DO FILE^DIE(,"DELETEFDA","ERR")
KILL DELETEFDA
End DoDot:1
+8 QUIT
+9 ;
ORDERCHECKLOCK(ERRORS,REQTYPE,DFN) ;
+1 NEW FOUND,REQUESTIEN,ORDERID
+2 ;
+3 SET FOUND=0
+4 SET REQUESTIEN=$PIECE($GET(REQTYPE),"|",2)
+5 SET REQTYPE=$$GET1^DIQ(409.85,REQUESTIEN,4,"I")
+6 IF REQTYPE="RTC"
Begin DoDot:1
+7 SET ORDERID=$$GET1^DIQ(409.85,REQUESTIEN,46,"I")
+8 IF '+$GET(ORDERID)
QUIT
+9 IF $DATA(^XTMP("ORLK-"_ORDERID))
DO ERRLOG^SDESJSON(.ERRORS,188)
SET FOUND=1
End DoDot:1
+10 QUIT FOUND
+11 ;
GETPID(APPOINTMENT,PID,REQUESTTYPE,REQUESTIEN) ;
+1 IF $LENGTH($GET(PID))
QUIT
+2 ;
+3 IF REQUESTTYPE="A"
SET PID=$$GET1^DIQ(409.85,REQUESTIEN,22,"I")
+4 IF REQUESTTYPE="R"
SET PID=$$GET1^DIQ(403.5,REQUESTIEN,5,"I")
+5 ;
+6 IF REQUESTTYPE="C"
IF $$GET1^DIQ(123,REQUESTIEN,17,"I")'=""
SET PID=$$GET1^DIQ(123,REQUESTIEN,17,"I")
+7 IF REQUESTTYPE="C"
IF PID=""
SET PID=$$GET1^DIQ(123,REQUESTIEN,.01,"I")
+8 ;
+9 SET APPOINTMENT("PATIENT INDICATED DATE")=$GET(PID)
+10 QUIT
+11 ;
