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

SDESBLKANDMOVE.m

Go to the documentation of this file.
SDESBLKANDMOVE ;ALB/TAW,MGD,LAB - BLOCK AND MOVE ;May 09,2023
 ;;5.3;Scheduling;**797,799,800,801,803,804,805,807,819,820,843**;Aug 13, 1993;Build 9
 ;;Per VHA Directive 6402, this routine should not be modified
 ;
 ; Reference to ^HOLIDAY is supported by IA #10038
 ; Reference to ^VA(200 is supported by IA #10060
 ;
APPTBLOCKMOVE(RETURN,APPTIEN,TORES,TODTNET,EASTRCKNGNMBR) ;
 N POP,SDAPPT,TODTFM,FROMRES,APPTARY,FN,SDECAPPTIENS,NEWAPPTIEN,TODTFMEND,TOTIMESCALE,SDTOCLIEN,CLINBEG,SDDUZ
 N FROMDTFM,FROMDTNET,TIMESCALEDIFF,SDSLOT2BLK,FROMTIMESCALE,SDORGCLIEN,TOENDDTFM
 N ENDDTFM,SDSEGMENTS,APPTLENGTH,SDPID,SDDATA44SLFROM,SDDATA44SLTO,CLINBEGFROM,CLINBEGTO,OVB
 S (POP,NEWAPPTIEN,TIMESCALEDIFF)=0,TODTFMEND=""
 D VALIDATEINPUT
 I 'POP D LOADAPPTDATA(.FN,.APPTARY,.SDECAPPTIENS)
 I 'POP D SLOTCOUNT
 I 'POP D VALIDATE
 I 'POP D COMPARETIMESCALE
 I 'POP D CHKAVAILABILITY^SDESBLKANDMOVE1(TORES,SDTOCLIEN,TODTNET,"T",TODTFM)
 I 'POP D CHKAVAILABILITY^SDESBLKANDMOVE1(FROMRES,SDORGCLIEN,FROMDTNET,"F",FROMDTFM)
 I 'POP D TOOVBCHECK^SDESBLKANDMOVE1(SDTOCLIEN,TODTFM,.APPTARY,FN,SDECAPPTIENS,.POP,.SDAPPT,.OVB)
 I 'POP D APPDEL
 I 'POP D
 .I APPTLENGTH<TOTIMESCALE D APPADD(APPTIEN,TODTFM,TOTIMESCALE,TORES,TOENDDTFM,FN,.APPTARY,SDECAPPTIENS) Q
 .I APPTLENGTH>=TOTIMESCALE D APPADD(APPTIEN,TODTFM,APPTLENGTH,TORES,TOENDDTFM,FN,.APPTARY,SDECAPPTIENS)
 I 'POP D PREBLOCK^SDESBLKANDMOVE1(FROMDTFM,FROMTIMESCALE,FROMRES,SDORGCLIEN,SDDATA44SLFROM,.SDSEGMENTS)
 I 'POP D
 .I NEWAPPTIEN S SDAPPT("BlockAndMove","NewAppointmentIEN")=NEWAPPTIEN
 .E  D ERRLOG^SDESJSON(.SDAPPT)  ;This should not happen but..force unknown error
 K ^TMP("SDEC57",$J)
 D BUILDER^SDESBLKANDMOVE1
 Q
 ;
VALIDATEINPUT ;Validate input parameters from the APPTBLOCKMOVE entry point
 S APPTIEN=$G(APPTIEN)
 I APPTIEN="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,3)
 I APPTIEN'="",'$D(^SDEC(409.84,APPTIEN,0)) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,4)
 ;
 S TORES=$G(TORES)
 I TORES="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,69)
 I TORES'="",'$D(^SDEC(409.831,TORES,0)) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,70)
 ;
 S TODTNET=$G(TODTNET)
 I TODTNET="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,76)
 I TODTNET'="" D
 .S TODTFM=$$NETTOFM^SDECDATE(TODTNET)
 .I TODTFM=-1 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,77) Q
 .I $P(TODTFM,".")<DT S POP=1 D ERRLOG^SDESJSON(.SDAPPT,71)
 ;validate EAS Tracking Number
 S EASTRCKNGNMBR=$TR($G(EASTRCKNGNMBR),"^"," ")
 I $L(EASTRCKNGNMBR) S EASTRCKNGNMBR=$$EASVALIDATE^SDESUTIL(EASTRCKNGNMBR)
 I EASTRCKNGNMBR=-1 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,142)
 ; validate DUZ
 S SDDUZ=$G(SDDUZ,DUZ)
 I SDDUZ="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Missing DUZ")
 I SDDUZ,'$$FIND1^DIC(200,,"A",DUZ,"","","SDERR") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Invalid DUZ")
 Q
 ;
LOADAPPTDATA(FN,APPTARY,SDECAPPTIENS) ;Load variables used throughout B&M
 N SDMSG
 S FN=409.84,SDECAPPTIENS=APPTIEN_","
 D GETS^DIQ(FN,SDECAPPTIENS,"**","IE","APPTARY","SDMSG") ;Data from SDEC APPOINTMENT file 409.84 for a record
 S FROMDTFM=$G(APPTARY(FN,SDECAPPTIENS,.01,"I"))
 S FROMDTNET=$$FMTONET^SDECDATE(FROMDTFM)
 S ENDDTFM=$G(APPTARY(FN,SDECAPPTIENS,.02,"I"))
 S FROMRES=$G(APPTARY(FN,SDECAPPTIENS,.07,"I"))   ;Originating Resource IEN
 S SDORGCLIEN=$$GET1^DIQ(409.831,FROMRES,.04,"I") ;Originating Clinic IEN
 S SDTOCLIEN=$$GET1^DIQ(409.831,TORES,.04,"I")    ;Destination Clinic IEN
 S SDPID=$G(APPTARY(FN,SDECAPPTIENS,.2,"E"))
 ; Load Resource & Clinic info
 S SDDATA44SLFROM=$G(^SC(SDORGCLIEN,"SL"))
 S CLINBEGFROM=$P(SDDATA44SLFROM,U,3)
 I CLINBEGFROM="" S CLINBEGFROM=8
 S CLINBEGFROM=$$PADCLTIME^SDESUTIL(CLINBEGFROM)
 S SDDATA44SLTO=$G(^SC(SDTOCLIEN,"SL"))
 S CLINBEGTO=$P(SDDATA44SLTO,U,3)
 I CLINBEGTO="" S CLINBEGTO=8
 S CLINBEGTO=$$PADCLTIME^SDESUTIL(CLINBEGTO)
 S FROMTIMESCALE=$P(^SDEC(409.831,FROMRES,0),"^",3)
 S TOTIMESCALE=$P(^SDEC(409.831,TORES,0),"^",3)
 I FROMTIMESCALE="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,73,"Time span")
 I TOTIMESCALE="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,73,"Time span")
 I 'POP S TOENDDTFM=$$FMADD^XLFDT(TODTFM,0,0,TOTIMESCALE,0) ;Appt end time at the Destination clinic
 D:'POP SDSEGMENTS
 Q
 ;
VALIDATE ; Simple validation
 N FROMDTFMPAD,TODTFMPAD,ENDDTFMPAD,SDDOW,HASPATRN
 ; From Appt must have same Dt Time as new appt.
 S FROMDTFMPAD=$$PADFMTIME^SDESUTIL($P(FROMDTFM,".",2))
 S TODTFMPAD=$$PADFMTIME^SDESUTIL($P(TODTFM,".",2))
 S ENDDTFMPAD=$$PADFMTIME^SDESUTIL($P(ENDDTFM,".",2))
 ;I $P(FROMDTFM,".")'=$P(TODTFM,".") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,"Appointment dates must match")
 I 'POP,+FROMDTFMPAD'=+TODTFMPAD S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,"Appointment times must match")
 ;
 ; Verify Start/End time of appt is on a single day
 I +ENDDTFMPAD<+FROMDTFMPAD S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Appointment must start & end on a single day") Q
 ;Current Appt must be in a 'scheduled' status only. Can not be checked in, cancelled, etc.
 N APPTSTAT
 S APPTSTAT=$$APPTSTS^SDEC50(APPTIEN,"","")
 I APPTSTAT["CANCELLED"!(APPTSTAT["NO-SHOW")!(APPTSTAT["CHECKED IN")!(APPTSTAT["CHECKED OUT") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,78)
 ; Check for restricted From or To clinic
 I '$$PRIVUSR^SDESCLINICUTIL(SDORGCLIEN,DUZ) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Privileged Originating clinic")
 I '$$PRIVUSR^SDESCLINICUTIL(SDTOCLIEN,DUZ) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Privileged Destination clinic")
 ; Don't allow B&M to prior to the start of the clinic availability
 I +$E($P(TODTFM,".",2)_"0000",1,4)<CLINBEGTO S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Prior to start of Destination clinic")
 ;Check if able to schedule on holiday
 I $$GET1^DIQ(44,SDTOCLIEN_",",1918.5,"I")'="Y",$$FIND1^DIC(40.5,,"B",$P(TODTFM,".",1),"","","SDERR") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Scheduling on holidays is not permitted")
 S SDDOW=$$DOW^XLFDT($P(TODTFM,".",1),1)
 ; Does Destination clinic have an availability pattern defined for this date
 ;S HASPATRN=$$HASPATRN^SDESBLKANDMOVE1(SDTOCLIEN,SDDOW,$P(TODTFM,".",1))
 ;I HASPATRN=0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic is not open on this date")
 Q
 ;
COMPARETIMESCALE ;Compare the Time Scale of the Clinic Resource from the original appt vs new appt
 ;The Time Scale of the original appointment can not be greater than the new appointment
 ;  Can't squeeze a 30 min appt into a 10 min slot.
 I 'POP,FROMTIMESCALE>TOTIMESCALE S POP=1 D ERRLOG^SDESJSON(.SDAPPT,74) Q
 ; Check for clinics being multiples
 I TOTIMESCALE#FROMTIMESCALE'=0  S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic not a multiple of Originating clinic")
 Q
 ;
SDSEGMENTS ; Build local array of slots with SCHEDULE and EVALUATE nodes
 N FRSTTMFMADJ,TOENDTMFMADJ,SDSEGSTTIM,SDSEGENDTIM,PADFROMDTFM,PADENDDTFM,CLINID
 ;
 ; Adjust new appt end time when moving a 60 min appt into a 30 min appt slot
 S APPTLENGTH=$$FMDIFF^XLFDT(ENDDTFM,FROMDTFM,2)/60  ;actual length current appt in min
 I APPTLENGTH'>0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Invalid appointment length calculation") Q
 I APPTLENGTH>TOTIMESCALE S TOENDDTFM=$$FMADD^XLFDT(TODTFM,0,0,APPTLENGTH,0)  ;Appt end time at the Destination clinic
 I TOENDDTFM=-1!($P(TODTFM,".",1)'=$P(TOENDDTFM,".",1)) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"New appointment crosses midnight") Q
 ;
 ; Init vars for the Destination clinic & appointment
 S PADFROMDTFM=$$PADFMTIME^SDESUTIL($P(TODTFM,".",2))
 S PADENDDTFM=$$PADFMTIME^SDESUTIL($P(TOENDDTFM,".",2))
 S FRSTTMFMADJ=$P($$FMADD^XLFDT(TODTFM,0,0,1,0),".",2)
 S FRSTTMFMADJ=$$PADFMTIME^SDESUTIL(FRSTTMFMADJ)
 S TOENDTMFMADJ=$P($$FMADD^XLFDT(TOENDDTFM,0,0,1,0),".",2)
 S TOENDTMFMADJ=$$PADFMTIME^SDESUTIL(TOENDTMFMADJ)
 S CLINID="T" ; To Clinic
 ; Load To clinic segments from T node of the Hospital Location file
 D SEGARRAY(SDTOCLIEN,TOTIMESCALE,TODTFM,CLINBEGTO,CLINID)
 Q:POP
 ; Determine the evaluation start time
 S SDSEGSTTIM=$O(SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",+FRSTTMFMADJ),-1)
 ; Would we ever have an appt prior to the defined clinic start time???
 I SDSEGSTTIM="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Prior to start of destination clinic") Q
 ; Appt start time = segment start time
 I +PADFROMDTFM=SDSEGSTTIM  S SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
 ; Appt starts within the segment. Segment 8-8:30 Appt starts at 8:15
 I +PADFROMDTFM>SDSEGSTTIM,(+PADFROMDTFM<SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM)) S SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
 ; Appt starts after the segment ends
 I +PADFROMDTFM>=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM) S SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE")=+PADFROMDTFM
 ; Determine the evaluation end time
 S SDSEGENDTIM=$O(SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",+TOENDTMFMADJ),-1)
 I SDSEGENDTIM="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Can't find slot end time in Originating clinic for evaluation") Q
 ; Appt end time fall within the segment
 I +PADENDDTFM>SDSEGENDTIM,+PADENDDTFM<=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM) S $P(SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE"),U,2)=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
 ; Appt end time > Segment end time
 I +PADENDDTFM>=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM) S $P(SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
 ; Appt end time = Segment end time
 I +PADENDDTFM=SDSEGENDTIM S $P(SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
 ;
 ; If additional time needs to be blocked at the originating clinic to account for moving from a 30 min clinic
 ; to a 60 min clinic.
 I FROMTIMESCALE<TOTIMESCALE D
 .I TODTFM<FROMDTFM S FROMDTFM=TODTFM
 .I TOENDDTFM>ENDDTFM S ENDDTFM=TOENDDTFM
 ;
 ; Init variables for the Originating clinic and appointment
 S PADFROMDTFM=$$PADFMTIME^SDESUTIL($P(FROMDTFM,".",2))
 S FRSTTMFMADJ=$P($$FMADD^XLFDT(FROMDTFM,0,0,1,0),".",2) ;increment by 1 min
 S FRSTTMFMADJ=$$PADFMTIME^SDESUTIL(FRSTTMFMADJ)
 S PADENDDTFM=$$PADFMTIME^SDESUTIL($P(ENDDTFM,".",2))
 S TOENDTMFMADJ=$P($$FMADD^XLFDT(ENDDTFM,0,0,1,0),".",2) ;increment by 1 min
 S TOENDTMFMADJ=$$PADFMTIME^SDESUTIL(TOENDTMFMADJ)
 S CLINID="F" ; From Clinic
 ; Load From clinic segments from T node of the Hospital Location file
 D SEGARRAY(SDORGCLIEN,FROMTIMESCALE,FROMDTFM,CLINBEGFROM,CLINID)
 Q:POP
 ; Determine the evaluation start time
 S SDSEGSTTIM=$O(SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",+FRSTTMFMADJ),-1)
 ; Would we ever have an appt prior to the defined clinic start time???
 I SDSEGSTTIM="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Can't find slot begin time in originating clinic for evaluation") Q
 ; Appt start time = segment start time
 I +PADFROMDTFM=SDSEGSTTIM  S SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
 ; Appt starts within the segment. Segment 8-8:30 Appt starts at 8:15
 I +PADFROMDTFM>SDSEGSTTIM,(+PADFROMDTFM<SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM)) S SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
 ; Appt starts after the segment ends
 I +PADFROMDTFM>=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM) S SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE")=+PADFROMDTFM
 ; Determine the evaluation end time
 S SDSEGENDTIM=$O(SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",+TOENDTMFMADJ),-1)
 I SDSEGENDTIM="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Can't find slot end time in originating clinic for evaluation") Q
 ; Appt end time fall within the segment
 I +PADENDDTFM>SDSEGENDTIM,+PADENDDTFM<=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM) S $P(SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE"),U,2)=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
 ; Appt end time > Segment end time
 I +PADENDDTFM>=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM) S $P(SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
 ; Appt end time = Segment end time
 I +PADENDDTFM=SDSEGENDTIM S $P(SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
 Q
 ;
SEGARRAY(CLIEN,TIMESCALE,FROMDTFM,CLINBEG,CLINID) ; Create local array to hold segments for validation comparisons
 N PATRNIEN,SDDOW,SDINDX,SDENDTIME,SDSLDATA,STOP,TINDX,I
 S PATRNIEN=$P(FROMDTFM,".",1)
 I '$D(^SC(CLIEN,"T",PATRNIEN,0)) D  Q:PATRNIEN'>0
 .S SDDOW=$$DOW^XLFDT(PATRNIEN,1)
 .F  S PATRNIEN=$O(^SC(CLIEN,"T",PATRNIEN),-1) Q:PATRNIEN=0  Q:$$DOW^XLFDT(PATRNIEN,1)=SDDOW
 .I PATRNIEN'>0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Availability definition not found")
 ; Loop to find start time definition
 S SDINDX=0
 F  S SDINDX=$O(^SC(CLIEN,"T",PATRNIEN,2,SDINDX)) Q:'SDINDX  D
 .S SDSLDATA=^SC(CLIEN,"T",PATRNIEN,2,SDINDX,0)
 .S SDENDTIME=$$FMADD^XLFDT(DT_"."_$P(SDSLDATA,U,1),,,TIMESCALE)
 .S SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",+$P(SDSLDATA,U,1))=+$$PADFMTIME^SDESUTIL($P(SDENDTIME,".",2))_"^"_$P(SDSLDATA,U,2)
 ; Check and build Teal area
 S SDINDX=0
 S SDINDX=$O(SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",SDINDX))
 Q:SDINDX=CLINBEG
 S STOP=""
 F I=1:1 D  Q:STOP
 .S TINDX=$$FMADD^XLFDT(DT_"."_$$PADLENGTH^SDESUTIL(SDINDX,"0",4,"F"),,,-TIMESCALE)
 .I $P(TINDX,".",1)'=DT S STOP=1 Q
 .I $P(TINDX,".",2)=24 D  Q
 ..S STOP=1,SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",0)=SDINDX_"^-"
 .S TINDX=+$$PADFMTIME^SDESUTIL($P(TINDX,".",2))
 .I +TINDX<=CLINBEG S STOP=1,TINDX=CLINBEG
 .S SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",+TINDX)=SDINDX_"^-"
 .S SDINDX=+TINDX
 Q
 ;
SLOTCOUNT ;
 ; Verifying that we don't have more than the max allowable slots defined for the period of time we are reviewing
 I $$IDTIMESLOT^SDESBLKANDMOVE1(SDORGCLIEN,1,"F") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"More than 1 appointment slot in Originating clinic") Q:POP
 Q
 ;
APPDEL ;Call APPDEL RPC to cancel the current appointment
 ;Input:
 ; SDECAPPTIEN [REQ] - IEN of appointment to cancel
 ;Assume:
 ; SDAPPT - Array of data returned by the RPC
 ;Output:
 ; Any errors logged by call to APPDEL RPC
 N RET,TEXT,SDCANRSN,SDUSRNOTE,SDCANDT,SDAPTYP,SDF
 S SDCANRSN=$$FIND1^DIC(409.2,,"B","BLOCK AND MOVE","","","SDERR")
 I 'SDCANRSN S SDCANRSN=""
 S SDF=""
 S SDAPTYP=$G(APPTARY(FN,SDECAPPTIENS,.22,"I"))
 ;I $P(SDAPTYP,";",2)="SD(403.5," S SDF=3
 D APPDEL^SDEC08(.RET,APPTIEN,"C",SDCANRSN,,,,,SDF,,,$G(EASTRCKNGNMBR))
 S TEXT=$G(^TMP("SDEC08",$J,"APPDEL",1))
 S TEXT=$P(TEXT,$C(30))
 I TEXT'="" D
 .S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,TEXT,"APPDEL^SDESAPPTSET")
 K ^TMP("SDEC08",$J)
 Q
 ;
APPADD(SDECAPPTIEN,SDECSTART,SDECLEN,SDECRES,SDECEND,FN,APPTARY,SDECAPPTIENS) ;entry point before calling APPADD^SDEC07
 ;Input:
 ; SDECAPPTIEN [REQ] - The IEN from SDEC APPOINTMENT File #409.84
 ; SDECSTART   [REQ] - The internal format of Appointment Start Time
 ; SDECLEN     [REQ] - Appointment length based on Time Scale from 409.831
 ; SDECRES     [REQ] - The IEN from SDEC RESOURCE File #409.831.
 ; SDECEND     [REQ] - Appointment end dt/tm in FM format
 ;
 ;Assume:
 ; APPTARY - Array of data from 409.84 for SDECAPPTIEN
 ; SDAPPT  - Array of data returned by the RPC
 ;
 ;Output:
 ; Errors logged by call to APPADD or set NEWAPPTIEN
 ;
 N SDRET,SDDFN,SDECNOTE,SDECATID,SDECCR,SDDDT,SDAPTYP,SDCL,SDEL,SDECY
 K ^TMP("SDEC07",$J)
 S SDDFN=$G(APPTARY(FN,SDECAPPTIENS,.05,"I")) ;Patient ID/DFN
 S SDCL=$P($G(^SDEC(409.831,+SDECRES,0)),U,4) ;Clinic IEN pointer to HOSPITAL LOCATION file 44
 ;S SDECEND=$$FMADD^XLFDT(SDECSTART,,,+SDECLEN) ;Appointment end time if SDECEND passed in as NULL
 S SDECNOTE=$G(APPTARY(FN,SDECAPPTIENS,1,1)) ;Note
 S SDECATID=$G(APPTARY(FN,SDECAPPTIENS,.13,"E")) ;WALKIN - WALKIN flag y=YES; n=NO default to NO
 I SDECATID=""!(SDECATID="NO") S SDECATID=$P($G(^DPT(SDDFN,"S",SDECSTART,0)),U,7) ;get the purpose of visit in the patient file if NULL in file 409.84
 S SDECATID=$S(SDECATID="YES"!(SDECATID=4):"WALKIN",1:SDECATID)
 S SDECCR=$S(SDECATID="WALKIN":0,1:1) ;routing slip
 S SDDDT=$G(APPTARY(FN,SDECAPPTIENS,.02,"I")) ;desired date of appointment
 S SDAPTYP=$$GET1^DIQ(FN,SDECAPPTIENS,.22,"E")
 S SDAPTYP=$S(SDAPTYP="APPT":"A",SDAPTYP="RECALL":"R",SDAPTYP="CONSULT":"C",SDAPTYP="EWL":"E",1:"")
 S SDAPTYP=SDAPTYP_"|"_$P($$GET1^DIQ(FN,SDECAPPTIENS,.22,"I"),";")
 S SDEL=$P($G(^DPT(SDDFN,.36)),U,1) ;Current Eligibility Code
 K SDECY
 D APPADD^SDEC07(.SDECY,$$FMTE^XLFDT(SDECSTART),$$FMTE^XLFDT(SDECEND),SDDFN,SDECRES,SDECLEN,$G(SDECNOTE),SDECATID,,,SDPID,,,,,SDAPTYP,,,SDCL,,,,,OVB,,SDEL,$G(EASTRCKNGNMBR)) ;ADD NEW APPOINTMENT
 ;
 N CNTR,ERROR
 S ERROR=""
 S CNTR=$O(^TMP("SDEC07",$J,0))
 I CNTR S ERROR=$G(^TMP("SDEC07",$J,CNTR))
 S ERROR=$$CTRL^XMXUTIL1(ERROR)
 I $P(ERROR,"^",2)'="" D
 .S POP=1
 .D ERRLOG^SDESJSON(.SDAPPT,52,$P(ERROR,"^",2),"APPADD^SDESAPPTSET")
 E  D
 .S NEWAPPTIEN=$P(ERROR,"^",1)
 .I $E(SDAPTYP,1)="R",$G(APPTARY(FN,SDECAPPTIENS,.22,"I"))'="" D
 ..N SDBM
 ..S SDBM(409.84,NEWAPPTIEN_",",.22)=$G(APPTARY(FN,SDECAPPTIENS,.22,"I"))
 ..D UPDATE^DIE("","SDBM","SDERR")
 ;
 K ^TMP("SDEC07",$J)
 Q