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