SDEC07A ;ALB/SAT,PC - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
;;5.3;Scheduling;**627,642,651,679,686,694**;Aug 13, 1993;Build 61
;;Per VHA Directive 2004-038, this routine should not be modified
;References made to ICR #6185 and #4837
;
; ICR
; ---
; 4837 - #123 Request/Consultation
; 7024 - #40.8 Medical Center Division
;
Q
;
OVBOOK(SDECY,SDCL,NSDT,SDECRES) ;RPC - OVERBOOK - Check if Overbook is allowed for given Clinic and Date.
;OVBOOK(SDECY,SDCL,NSDT,SDECRES) external parameter tag is in SDEC
; .SDECY = returned pointer to OVERBOOK data
; SDCL = clinic code - pointer to Hospital Location file ^SC
; NSDT = date/time of new appointment
; SDECRES = resource to check for overbook
N %DT,AP,SDECI,OB,SDBK,OBCNT,OBMAX,SDCLN,SDCLRES,SDCLSL,SDCNT,SDRET,SDT,SDTD,SDTE,X,Y
N SD30,SDARR,OBCNTSUM
S OBCNTSUM=0
; SDTD = new schedule Date only in FM format
; SDT = loop value for $o through schedules
; SDTE = end of loop schedule
; NSDT = new appointment schedule Date/Time will be converted to FM format
S SDECI=0
S SDECY="^TMP(""SDEC"","_$J_")"
K @SDECY
S @SDECY@(0)="T00020ERRORID"_$C(30)
;check for valid Hospital location
I '+SDCL D ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.") Q
I '$D(^SC(SDCL,0)) D ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.") Q
;check for valid resource ID
I '+SDECRES D ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.") Q
I '$D(^SDEC(409.831,SDECRES,0)) D ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.") Q
;check for valid DATE/TIME
;
; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
;
;S %DT="T"
;S X=NSDT
;D ^%DT ; GET FM FORMAT FOR APPOINTMENT DATE/TIME
;S NSDT=Y
S NSDT=$$NETTOFM^SDECDATE(NSDT,"Y","N") ;
I NSDT=-1 D ERR1("Invalid Appointment Date.") Q
S SDTD=$P(NSDT,".")
; data header
; OVERBOOK 0=not overbooked; 1=overbooked
S @SDECY@(0)="T00020OVERBOOK"_$C(30)
;get allowed number of overbookings for clinic
S SDCLSL=$G(^SC(SDCL,"SL"))
S OBMAX=$P(SDCLSL,U,7)
I '+OBMAX S (OBCNT,OBMAX)=0 G XIT
N SDAB,SLOTSIZE
S SDAB="^TMP("_$J_",""SDEC"",""BLKS"")"
S SLOTSIZE="^TMP("_$J_",""SDEC"",""SLOTSIZE"")"
K @SDAB,@SLOTSIZE
;get original slot sizes
D GETSLOTS^SDEC04(SLOTSIZE,SDECRES,SDTD,SDTD_".2359")
;get current appt availability
D GETSLOTS^SDEC57(SDAB,SDECRES,SDTD,SDTD_".2359")
N IDX,SDR,SDSTART,SDSTOP,SDSLOTS,XX,IDX2,YY
;restore original slot sizes into appts slots
S IDX="" F S IDX=$O(@SLOTSIZE@(IDX)) Q:'IDX D
.S XX=@SLOTSIZE@(IDX)
.S SDSTART=$P(XX,U,2),SDSTOP=$P(XX,U,3),SDSLOTS=$P(XX,U,4)
.S IDX2="" F S IDX2=$O(@SDAB@(IDX2)) Q:'IDX2 D
..S YY=@SDAB@(IDX2)
..S:($P(YY,U,2)'<SDSTART)&($P(YY,U,3)'>SDSTOP) $P(@SDAB@(IDX2),U,4)=SDSLOTS
;find overbooks
S IDX="" F S IDX=$O(@SDAB@(IDX)) Q:IDX="" D
.S XX=@SDAB@(IDX)
.S SDSTART=$P(XX,U,2),SDSTOP=$P(XX,U,3),SDSLOTS=$P(XX,U,4)
.;loop thru schedule
.; SDBK(<appt time>,<appt end time>)=counter starting at 0
.K SDBK ;overbook counter array
.S SDRET="" D CRSCHED^SDEC(.SDRET,SDECRES,SDSTART,SDSTOP)
.K SDARR
.S SD30=1,SDCNT=0,SDT=0 F S SDT=$O(@SDRET@(SDT)) Q:SDT="" D
..S SDR=$G(@SDRET@(SDT))
..I $P(SDR,U,1)[$c(30) S SD30=1 Q
..Q:SD30'=1
..S SDCNT=SDCNT+1
..S SDARR($P(SDR,U,1))=""
..S SD30=0
.S SDCNT=0 F S SDCNT=$O(SDARR(SDCNT)) Q:SDCNT="" D
..S SDR=$G(^SDEC(409.84,+SDCNT,0))
..S SDT=$P(SDR,U,1)
..S SDTE=$P(SDR,U,2)
..Q:$P(SDR,U,12)]"" ;don't count cancelled appts
..;if time ranges overlap, add to SDBK array
..I (SDTE>SDT)&(((SDT'<SDSTART)&(SDT<SDSTOP))!((SDTE>SDSTART)&(SDTE'>SDSTOP))!((SDT'>SDSTART)&(SDTE'<SDSTOP))) D
...D CKOB(SDT,SDTE,.SDBK)
..;;D CKOB($P(SDT,".")_".0000",$P(SDTE,".")_".2359",.SDBK)
.S OBCNT=$$CNTOB(.SDBK,SDECRES,SDTD,OBMAX,SDAB)
.S OBCNTSUM=OBCNTSUM+OBCNT
.K @SDRET,SDBK
XIT ;
S SDECI=SDECI+1
S @SDECY@(SDECI)=$S(OBCNTSUM<OBMAX:"YES",1:"NO")
S SDECI=SDECI+1
S @SDECY@(SDECI)=$C(30)
S SDECI=SDECI+1
S @SDECY@(SDECI)=$C(31)
Q
;
;find appointment in SDEC APPOINTMENT file
SDECAP(SDECSDT,DFN) ;
N SDECAPN,SDECRES,ID
S SDECRES=0
S ID=0
F S ID=$O(^SDEC(409.84,"B",SDECSDT,ID)) Q:ID'>0 Q:SDECRES'=0 D
. S SDECAPN=$G(^SDEC(409.84,ID,0))
. I $P(SDECAPN,U,5)=DFN S SDECRES=$P(SDECAPN,U,7)
Q SDECRES
;
;check if appointment start/stop is in range of an existing appointment
CKOB(START,STOP,SDBK) ;called internally
; START = appointment start date/time in FM format
; STOP = appointment stop date/time in FM format
; .SDBK = bookings Array - SDBK(<appt time>,<appt end time>)=counter starting at 0
N B,E,OB,OBF
S OBF=0
S B=""
F S B=$O(SDBK(B)) Q:B'>0 D Q:+OBF
. S E="" F S E=$O(SDBK(B,E)) Q:E'>0 D Q:+OBF
. . S OB=SDBK(B,E)
. . S OBF=1
. . ;S OBF=(($$FMADD^XLFDT(START,B,2)'<0)&($$FMADD^XLFDT(START,E,2)<0))!(($$FMADD^XLFDT(STOP,B,2)>0)&($$FMADD^XLFDT(STOP,E,2)'<0))
. . ;S OBF=(($P(START,".",2)'<$P(B,".",2))&($P(START,".",2)'>$P(E,".",2)))!(($P(STOP,".",2)>$P(B,".",2))&($P(STOP,".",2)'>$P(E,".",2)))
. . I OBF S SDBK(B,E)=(OB+1)
I 'OBF S SDBK(START,STOP)=1
;
Q
;
;count overbookings
CNTOB(SDBK,SDECRES,SDTD,OBMAX,SDAB) ;called internally
N AB,ABF,ABN,CNT,BK,SLOTS,B,E
S BK=""
S CNT=0
S B="" F S B=$O(SDBK(B)) Q:B="" D Q:CNT'<OBMAX
. S E="" F S E=$O(SDBK(B,E)) Q:E="" D Q:CNT'<OBMAX
. . S BK=SDBK(B,E)
. . Q:'+BK
. . S SLOTS=$$SLOTS(B,E,SDAB) ;find access block
. . I '+SLOTS S CNT=CNT+BK
. . E S BK=BK-SLOTS S:BK<0 BK=0 S CNT=CNT+BK
Q CNT
SLOTS(B,E,SDAB) ;find access block
N ABF,ABN,SDI,SLOTS
S SLOTS=""
S SDI=0 F S SDI=$O(@SDAB@(SDI)) Q:SDI'>0 D Q:+ABF
.S ABN=@SDAB@(SDI)
.S ABF=((B'<$P(ABN,U,2))&(B<$P(ABN,U,3)))!((E>$P(ABN,U,2))&(E'>$P(ABN,U,3)))
.S:ABF SLOTS=+$P(ABN,U,4)
Q SLOTS
;
REQSET(SDRIEN,SDPROV,SDUSR,SDACT,SDECTYP,SDECNOTE,SAVESTRT,SDECRES,SDDFN) ;add SCHEDULED activity to REQUEST/CONSULTATION file
;INPUT:
; SDRIEN - (required) pointer to RFEQUEST/CONSULTATION file 123
; SDPROV - (required) Provider pointer to NEW PERSON
; SDUSR - (optional) User that entered appointment pointer to NEW PERSON
; SDACT - (required) ACTIVITY type to add 1=SCHEDULED 2=STATUS CHANGE
; SDECTYP - (required if SDACT=2) appointment Status valid values:
; C=CANCELLED BY CLINIC
; PC=CANCELLED BY PATIENT
; SDECNOTE - Comments from Appointment
; SAVESTRT - Appointment time in external format ;alb/sat 651 corrected comment
; SDECRES - Appointment Resource
N SDDT,SDFDA,SDI,SDIEN,SDOA,SDOS,SDPDC,SDSCHED,SDSCHEDF,SDSTAT,SDTXT,SDERR,Y,SDPCM
S SDACT=$G(SDACT)
S SAVESTRT=$G(SAVESTRT)
S SDECRES=$G(SDECRES)
Q:"12"'[SDACT
S SDSCHEDF=0
S SDUSR=$G(SDUSR)
S:SDUSR="" SDUSR=DUZ
S:'$D(^VA(200,+SDUSR,0)) SDUSR=DUZ ;take this out
S SDSCHED=$$GETIEN^SDEC51("SCHEDULED")
S SDSTAT=$$GETIEN^SDEC51("STATUS CHANGE")
S SDPDC=$O(^ORD(100.01,"B","DISCONTINUED",0))
;ajf ; Check for completed Consult
S SDPCM=$O(^ORD(100.01,"B","COMPLETE",0))
I SDACT=1,SDSCHED="" Q
I SDACT=2,SDSTAT="" Q
;ajf ; Check for completed Consult
S SDCPS=$$GET1^DIQ(123,SDRIEN_",",8,"I")
Q:SDCPS=SDPDC!(SDCPS=SDPCM)
;Q:$$GET1^DIQ(123,SDRIEN_",",8,"I")=SDPDC ;never update file 123 if CPRS STATUS is DISCONTINUED
;Q:$$GET1^DIQ(123,SDRIEN_",",8,"I")=SDPCM ;never update file 123 if CPRS STATUS is COMPLETE
S SDECNOTE=$G(SDECNOTE)
;it is possible to have multiple scheduled activities; make sure there is not already a SCHEDULED activity
;S SDI=0 F S SDI=$O(^GMR(123,SDRIEN,40,SDI)) Q:SDI'>0 D Q:+SDSCHEDF
;.I $P($G(^GMR(123,SDRIEN,40,SDI,0)),U,2)=SDSCHED S SDSCHEDF=1 Q
;Q:+SDSCHEDF
S SDDT=$$NOW^XLFDT() ;*zeb 12/13/17 679 don't use $E to remove seconds
;
; Replaced with call to SDCNSLT below. wtc/zeb 3.21.18 patch 686 ;
;
;S SDFDA(123.02,"+1,"_SDRIEN_",",.01)=SDDT ;ICR 6185
;S SDFDA(123.02,"+1,"_SDRIEN_",",1)=$S(SDACT=1:SDSCHED,SDACT=2:SDSTAT,1:"") ;ICR 6185
;S SDFDA(123.02,"+1,"_SDRIEN_",",2)=SDDT ;ICR 6185
;S SDFDA(123.02,"+1,"_SDRIEN_",",3)=SDPROV ;ICR 6185
;S SDFDA(123.02,"+1,"_SDRIEN_",",4)=SDUSR ;ICR 6185
;D UPDATE^DIE("","SDFDA","SDIEN")
S SDTXT=""
;MGH modified to add in note text and appointment data
I SDACT=1 D
.;
.; Disabled lines below because they exist in SDCNSLT.
.; wtc/zeb 3.22.18 patch 686
.;
.;S SDTXT(1)=$P($G(^SDEC(409.831,+SDECRES,0)),U,1)_" Consult Appt. on "_SAVESTRT
.;I SDECNOTE'="" S SDTXT(2)=SDECNOTE
. N %DT,X,SD,TMPYCLNC ;
.;
.; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
.;
. S SD=$$NETTOFM^SDECDATE(SAVESTRT,"Y","N") ;
. ;S X=SAVESTRT,%DT="T" D ^%DT S SD=Y ;
. S TMPYCLNC=$P($G(^SDEC(409.831,+SDECRES,0)),U,4) I TMPYCLNC'="" S TMPYCLNC=TMPYCLNC_U_$P(^SC(TMPYCLNC,0),U,1) ;
. D EDITCS^SDCNSLT(SD,SDECNOTE,TMPYCLNC,SDRIEN) ; Changed "" to SDECNOTE - wtc 686 11/7/2018
I SDACT=2 D
.;
.; Disabled lines below because they exist in SDCNSLT.
.; wtc/zeb 3.22.18 patch 686
.;
.;S SDECTYP=$G(SDECTYP)
.;S SDTXT(1)=$P($G(^SDEC(409.831,+SDECRES,0)),U,1)_" Appt. on "_SAVESTRT_" was cancelled"_$S(SDECTYP["P":" by the Patient.",SDECTYP["C":" by the Clinic.",1:".") ;alb/sat 651 include appt info
.;I SDECNOTE'="" S SDTXT(2)="Remarks: "_SDECNOTE
. N DFN,%DT,X,SDTTM,SDSC,SDPL ;
. S DFN=$P($G(^GMR(123,SDRIEN,0)),U,2)
.;
.; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
.;
. ;Q:$G(SDRIEN)=""!($G(DFN)="")!(SDDFN'=DFN)!($G(SDRIEN)'=$G(SDRIEN1)) ; CLT, INC8706878, SD*5.3*694, 02/03/2020 PWC COMMENTED OUT FOR NOW UNTIL TESTED 2/3/2020
. S SDTTM=$$NETTOFM^SDECDATE(SAVESTRT,"Y","N") ;
. ;S X=SAVESTRT,%DT="T" D ^%DT S SDTTM=Y ;
. S SDSC=$P($G(^SDEC(409.831,+SDECRES,0)),U,4) ;
. S SDPL=0 F S SDPL=$O(^SC(SDSC,"S",SDTTM,1,SDPL)) Q:'SDPL Q:$P(^(SDPL,0),U,1)=DFN ;
. K TMPD ; prevent extra comments added to 2nd cancellation - wtc 694 7/24/2019
. D SDECCAN^SDCNSLT(SDRIEN,DFN,SDTTM,SDSC,SDECTYP,SDPL,SDECNOTE) ;*zeb 686 10/30/18 send comments to consult
Q ;
;
; Lines below disabled by calls to SDCNSLT.
; wtc/zeb 3.22.18 patch 686
;
;I $D(SDTXT) D
;.D WP^DIE(123.02,SDIEN(1)_","_SDRIEN_",",5,"","SDTXT","SDERR") ;ICR 6185
;K SDFDA ;alb/sat 651
;set CPRS status field ICR 6185
;S SDOS=$O(^ORD(100.01,"B","SCHEDULED",0))
;S SDOA=$O(^ORD(100.01,"B","ACTIVE",0))
;I SDOS'="" D
;.;K SDFDA ;alb/sat 651 moved up
;.S SDFDA(123,SDRIEN_",",8)=$S(SDACT=1:SDOS,1:SDOA)
;.;D UPDATE^DIE("","SDFDA") ;ICR 6185 ;alb/sat 651 moved down out of IF scope
;S:+$G(SDSCHED) SDFDA(123,SDRIEN_",",9)=$S(SDACT=1:SDSCHED,1:SDSTAT) ;alb/sat 651 - set LAST ACTION TAKEN ICR 4837
;D:$D(SDFDA) UPDATE^DIE("","SDFDA") ;alb/sat 651
;Q
;
EWL(WLIEN,APPDT,SDCL,SVCP,SVCPR,NOTE,SDAPPTYP) ;update SD WAIT LIST at appointment add
;INPUT:
; WLIEN = Wait List ID pointer to SD WAIT LIST file 409.3
; APPDT = Appointment date/time (Scheduled Date of appt) in fm format
; SDCL = Clinic ID pointer to HOSPITAL LOCATION file 44
; SVCP = Service Connected Percentage numeric 0-100
; SVCPR = Service Connected Priority 0:NO 1:YES
; NOTE = Comment only 1st 60 characters are used
; SDAPPTYP - (optional) Appointment type ID pointer to APPOINTMENT TYPE file 409.1
;
;all input must be verified by calling routine
N SDDIV,SDFDA,SDSN
S:+$G(SDAPPTYP) SDFDA(409.3,WLIEN_",",8.7)=SDAPPTYP
S SDFDA(409.3,WLIEN_",",13)=APPDT ;SCHEDULED DATE OF APPT = APPDT (SDECSTART)
S SDFDA(409.3,WLIEN_",",13.1)=$P($$NOW^XLFDT,".",1) ;DATE APPT. MADE = TODAY
S SDFDA(409.3,WLIEN_",",13.2)=SDCL ;APPT CLINIC = SDCL (SDECSCD)
S SDFDA(409.3,WLIEN_",",13.3)=$P($G(^SC(SDCL,0)),U,4) ;APPT INSTITUTION = Get from 44 using SDCL
S SDFDA(409.3,WLIEN_",",13.4)=$P($G(^SC(SDCL,0)),U,7) ;APPT STOP CODE = Get from 44 using SDCL
S SDDIV=$P($G(^SC(SDCL,0)),U,15)
S SDSN=$S(SDDIV'="":$P($G(^DG(40.8,SDDIV,0)),U,2),1:"")
S SDFDA(409.3,WLIEN_",",13.6)=SDSN ;APPT STATION NUMBER
S SDFDA(409.3,WLIEN_",",13.7)=DUZ ;APPT CLERK = Current User
S SDFDA(409.3,WLIEN_",",13.8)="R" ;APPT STATUS = R:Scheduled/Kept
S:SVCP'="" SDFDA(409.3,WLIEN_",",14)=SVCP ;SERVICE CONNECTED PERCENTAGE = SVCP (SDSVCP)
S:SVCPR'="" SDFDA(409.3,WLIEN_",",15)=SVCPR ;SERVICE CONNECTED PRIORITY = SVCPR (SDSVCPR)
S:$G(NOTE)'="" SDFDA(409.3,WLIEN_",",25)=NOTE
S SDFDA(409.3,WLIEN_",",27)="U" ;EWL ENROLLEE STATUS = U:UNDETERMINED
S SDFDA(409.3,WLIEN_",",27.2)=0 ;EWL ENROLLEE DATABASE FILE = 0:NONE
S SDFDA(409.3,WLIEN_",",28)=DUZ ;EDITING USER = Current User
D UPDATE^DIE("","SDFDA")
Q
;
ERROR ;
D ERR1("Error")
Q
;
ERR1(SDECERR) ;Error processing
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=SDECERR_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=$C(31)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC07A 13393 printed Apr 09, 2024@21:47:27 Page 2
SDEC07A ;ALB/SAT,PC - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
+1 ;;5.3;Scheduling;**627,642,651,679,686,694**;Aug 13, 1993;Build 61
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;References made to ICR #6185 and #4837
+4 ;
+5 ; ICR
+6 ; ---
+7 ; 4837 - #123 Request/Consultation
+8 ; 7024 - #40.8 Medical Center Division
+9 ;
+10 QUIT
+11 ;
OVBOOK(SDECY,SDCL,NSDT,SDECRES) ;RPC - OVERBOOK - Check if Overbook is allowed for given Clinic and Date.
+1 ;OVBOOK(SDECY,SDCL,NSDT,SDECRES) external parameter tag is in SDEC
+2 ; .SDECY = returned pointer to OVERBOOK data
+3 ; SDCL = clinic code - pointer to Hospital Location file ^SC
+4 ; NSDT = date/time of new appointment
+5 ; SDECRES = resource to check for overbook
+6 NEW %DT,AP,SDECI,OB,SDBK,OBCNT,OBMAX,SDCLN,SDCLRES,SDCLSL,SDCNT,SDRET,SDT,SDTD,SDTE,X,Y
+7 NEW SD30,SDARR,OBCNTSUM
+8 SET OBCNTSUM=0
+9 ; SDTD = new schedule Date only in FM format
+10 ; SDT = loop value for $o through schedules
+11 ; SDTE = end of loop schedule
+12 ; NSDT = new appointment schedule Date/Time will be converted to FM format
+13 SET SDECI=0
+14 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+15 KILL @SDECY
+16 SET @SDECY@(0)="T00020ERRORID"_$CHAR(30)
+17 ;check for valid Hospital location
+18 IF '+SDCL
DO ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.")
QUIT
+19 IF '$DATA(^SC(SDCL,0))
DO ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.")
QUIT
+20 ;check for valid resource ID
+21 IF '+SDECRES
DO ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.")
QUIT
+22 IF '$DATA(^SDEC(409.831,SDECRES,0))
DO ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.")
QUIT
+23 ;check for valid DATE/TIME
+24 ;
+25 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+26 ;
+27 ;S %DT="T"
+28 ;S X=NSDT
+29 ;D ^%DT ; GET FM FORMAT FOR APPOINTMENT DATE/TIME
+30 ;S NSDT=Y
+31 ;
SET NSDT=$$NETTOFM^SDECDATE(NSDT,"Y","N")
+32 IF NSDT=-1
DO ERR1("Invalid Appointment Date.")
QUIT
+33 SET SDTD=$PIECE(NSDT,".")
+34 ; data header
+35 ; OVERBOOK 0=not overbooked; 1=overbooked
+36 SET @SDECY@(0)="T00020OVERBOOK"_$CHAR(30)
+37 ;get allowed number of overbookings for clinic
+38 SET SDCLSL=$GET(^SC(SDCL,"SL"))
+39 SET OBMAX=$PIECE(SDCLSL,U,7)
+40 IF '+OBMAX
SET (OBCNT,OBMAX)=0
GOTO XIT
+41 NEW SDAB,SLOTSIZE
+42 SET SDAB="^TMP("_$JOB_",""SDEC"",""BLKS"")"
+43 SET SLOTSIZE="^TMP("_$JOB_",""SDEC"",""SLOTSIZE"")"
+44 KILL @SDAB,@SLOTSIZE
+45 ;get original slot sizes
+46 DO GETSLOTS^SDEC04(SLOTSIZE,SDECRES,SDTD,SDTD_".2359")
+47 ;get current appt availability
+48 DO GETSLOTS^SDEC57(SDAB,SDECRES,SDTD,SDTD_".2359")
+49 NEW IDX,SDR,SDSTART,SDSTOP,SDSLOTS,XX,IDX2,YY
+50 ;restore original slot sizes into appts slots
+51 SET IDX=""
FOR
SET IDX=$ORDER(@SLOTSIZE@(IDX))
if 'IDX
QUIT
Begin DoDot:1
+52 SET XX=@SLOTSIZE@(IDX)
+53 SET SDSTART=$PIECE(XX,U,2)
SET SDSTOP=$PIECE(XX,U,3)
SET SDSLOTS=$PIECE(XX,U,4)
+54 SET IDX2=""
FOR
SET IDX2=$ORDER(@SDAB@(IDX2))
if 'IDX2
QUIT
Begin DoDot:2
+55 SET YY=@SDAB@(IDX2)
+56 if ($PIECE(YY,U,2)'<SDSTART)&($PIECE(YY,U,3)'>SDSTOP)
SET $PIECE(@SDAB@(IDX2),U,4)=SDSLOTS
End DoDot:2
End DoDot:1
+57 ;find overbooks
+58 SET IDX=""
FOR
SET IDX=$ORDER(@SDAB@(IDX))
if IDX=""
QUIT
Begin DoDot:1
+59 SET XX=@SDAB@(IDX)
+60 SET SDSTART=$PIECE(XX,U,2)
SET SDSTOP=$PIECE(XX,U,3)
SET SDSLOTS=$PIECE(XX,U,4)
+61 ;loop thru schedule
+62 ; SDBK(<appt time>,<appt end time>)=counter starting at 0
+63 ;overbook counter array
KILL SDBK
+64 SET SDRET=""
DO CRSCHED^SDEC(.SDRET,SDECRES,SDSTART,SDSTOP)
+65 KILL SDARR
+66 SET SD30=1
SET SDCNT=0
SET SDT=0
FOR
SET SDT=$ORDER(@SDRET@(SDT))
if SDT=""
QUIT
Begin DoDot:2
+67 SET SDR=$GET(@SDRET@(SDT))
+68
*** ERROR ***
IF $PIECE(SDR,U,1)[$c(30)
SET SD30=1
QUIT
+69 if SD30'=1
QUIT
+70 SET SDCNT=SDCNT+1
+71 SET SDARR($PIECE(SDR,U,1))=""
+72 SET SD30=0
End DoDot:2
+73 SET SDCNT=0
FOR
SET SDCNT=$ORDER(SDARR(SDCNT))
if SDCNT=""
QUIT
Begin DoDot:2
+74 SET SDR=$GET(^SDEC(409.84,+SDCNT,0))
+75 SET SDT=$PIECE(SDR,U,1)
+76 SET SDTE=$PIECE(SDR,U,2)
+77 ;don't count cancelled appts
if $PIECE(SDR,U,12)]""
QUIT
+78 ;if time ranges overlap, add to SDBK array
+79 IF (SDTE>SDT)&(((SDT'<SDSTART)&(SDT<SDSTOP))!((SDTE>SDSTART)&(SDTE'>SDSTOP))!((SDT'>SDSTART)&(SDTE'<SDSTOP)))
Begin DoDot:3
+80 DO CKOB(SDT,SDTE,.SDBK)
End DoDot:3
+81 ;;D CKOB($P(SDT,".")_".0000",$P(SDTE,".")_".2359",.SDBK)
End DoDot:2
+82 SET OBCNT=$$CNTOB(.SDBK,SDECRES,SDTD,OBMAX,SDAB)
+83 SET OBCNTSUM=OBCNTSUM+OBCNT
+84 KILL @SDRET,SDBK
End DoDot:1
XIT ;
+1 SET SDECI=SDECI+1
+2 SET @SDECY@(SDECI)=$SELECT(OBCNTSUM<OBMAX:"YES",1:"NO")
+3 SET SDECI=SDECI+1
+4 SET @SDECY@(SDECI)=$CHAR(30)
+5 SET SDECI=SDECI+1
+6 SET @SDECY@(SDECI)=$CHAR(31)
+7 QUIT
+8 ;
+9 ;find appointment in SDEC APPOINTMENT file
SDECAP(SDECSDT,DFN) ;
+1 NEW SDECAPN,SDECRES,ID
+2 SET SDECRES=0
+3 SET ID=0
+4 FOR
SET ID=$ORDER(^SDEC(409.84,"B",SDECSDT,ID))
if ID'>0
QUIT
if SDECRES'=0
QUIT
Begin DoDot:1
+5 SET SDECAPN=$GET(^SDEC(409.84,ID,0))
+6 IF $PIECE(SDECAPN,U,5)=DFN
SET SDECRES=$PIECE(SDECAPN,U,7)
End DoDot:1
+7 QUIT SDECRES
+8 ;
+9 ;check if appointment start/stop is in range of an existing appointment
CKOB(START,STOP,SDBK) ;called internally
+1 ; START = appointment start date/time in FM format
+2 ; STOP = appointment stop date/time in FM format
+3 ; .SDBK = bookings Array - SDBK(<appt time>,<appt end time>)=counter starting at 0
+4 NEW B,E,OB,OBF
+5 SET OBF=0
+6 SET B=""
+7 FOR
SET B=$ORDER(SDBK(B))
if B'>0
QUIT
Begin DoDot:1
+8 SET E=""
FOR
SET E=$ORDER(SDBK(B,E))
if E'>0
QUIT
Begin DoDot:2
+9 SET OB=SDBK(B,E)
+10 SET OBF=1
+11 ;S OBF=(($$FMADD^XLFDT(START,B,2)'<0)&($$FMADD^XLFDT(START,E,2)<0))!(($$FMADD^XLFDT(STOP,B,2)>0)&($$FMADD^XLFDT(STOP,E,2)'<0))
+12 ;S OBF=(($P(START,".",2)'<$P(B,".",2))&($P(START,".",2)'>$P(E,".",2)))!(($P(STOP,".",2)>$P(B,".",2))&($P(STOP,".",2)'>$P(E,".",2)))
+13 IF OBF
SET SDBK(B,E)=(OB+1)
End DoDot:2
if +OBF
QUIT
End DoDot:1
if +OBF
QUIT
+14 IF 'OBF
SET SDBK(START,STOP)=1
+15 ;
+16 QUIT
+17 ;
+18 ;count overbookings
CNTOB(SDBK,SDECRES,SDTD,OBMAX,SDAB) ;called internally
+1 NEW AB,ABF,ABN,CNT,BK,SLOTS,B,E
+2 SET BK=""
+3 SET CNT=0
+4 SET B=""
FOR
SET B=$ORDER(SDBK(B))
if B=""
QUIT
Begin DoDot:1
+5 SET E=""
FOR
SET E=$ORDER(SDBK(B,E))
if E=""
QUIT
Begin DoDot:2
+6 SET BK=SDBK(B,E)
+7 if '+BK
QUIT
+8 ;find access block
SET SLOTS=$$SLOTS(B,E,SDAB)
+9 IF '+SLOTS
SET CNT=CNT+BK
+10 IF '$TEST
SET BK=BK-SLOTS
if BK<0
SET BK=0
SET CNT=CNT+BK
End DoDot:2
if CNT'<OBMAX
QUIT
End DoDot:1
if CNT'<OBMAX
QUIT
+11 QUIT CNT
SLOTS(B,E,SDAB) ;find access block
+1 NEW ABF,ABN,SDI,SLOTS
+2 SET SLOTS=""
+3 SET SDI=0
FOR
SET SDI=$ORDER(@SDAB@(SDI))
if SDI'>0
QUIT
Begin DoDot:1
+4 SET ABN=@SDAB@(SDI)
+5 SET ABF=((B'<$PIECE(ABN,U,2))&(B<$PIECE(ABN,U,3)))!((E>$PIECE(ABN,U,2))&(E'>$PIECE(ABN,U,3)))
+6 if ABF
SET SLOTS=+$PIECE(ABN,U,4)
End DoDot:1
if +ABF
QUIT
+7 QUIT SLOTS
+8 ;
REQSET(SDRIEN,SDPROV,SDUSR,SDACT,SDECTYP,SDECNOTE,SAVESTRT,SDECRES,SDDFN) ;add SCHEDULED activity to REQUEST/CONSULTATION file
+1 ;INPUT:
+2 ; SDRIEN - (required) pointer to RFEQUEST/CONSULTATION file 123
+3 ; SDPROV - (required) Provider pointer to NEW PERSON
+4 ; SDUSR - (optional) User that entered appointment pointer to NEW PERSON
+5 ; SDACT - (required) ACTIVITY type to add 1=SCHEDULED 2=STATUS CHANGE
+6 ; SDECTYP - (required if SDACT=2) appointment Status valid values:
+7 ; C=CANCELLED BY CLINIC
+8 ; PC=CANCELLED BY PATIENT
+9 ; SDECNOTE - Comments from Appointment
+10 ; SAVESTRT - Appointment time in external format ;alb/sat 651 corrected comment
+11 ; SDECRES - Appointment Resource
+12 NEW SDDT,SDFDA,SDI,SDIEN,SDOA,SDOS,SDPDC,SDSCHED,SDSCHEDF,SDSTAT,SDTXT,SDERR,Y,SDPCM
+13 SET SDACT=$GET(SDACT)
+14 SET SAVESTRT=$GET(SAVESTRT)
+15 SET SDECRES=$GET(SDECRES)
+16 if "12"'[SDACT
QUIT
+17 SET SDSCHEDF=0
+18 SET SDUSR=$GET(SDUSR)
+19 if SDUSR=""
SET SDUSR=DUZ
+20 ;take this out
if '$DATA(^VA(200,+SDUSR,0))
SET SDUSR=DUZ
+21 SET SDSCHED=$$GETIEN^SDEC51("SCHEDULED")
+22 SET SDSTAT=$$GETIEN^SDEC51("STATUS CHANGE")
+23 SET SDPDC=$ORDER(^ORD(100.01,"B","DISCONTINUED",0))
+24 ;ajf ; Check for completed Consult
+25 SET SDPCM=$ORDER(^ORD(100.01,"B","COMPLETE",0))
+26 IF SDACT=1
IF SDSCHED=""
QUIT
+27 IF SDACT=2
IF SDSTAT=""
QUIT
+28 ;ajf ; Check for completed Consult
+29 SET SDCPS=$$GET1^DIQ(123,SDRIEN_",",8,"I")
+30 if SDCPS=SDPDC!(SDCPS=SDPCM)
QUIT
+31 ;Q:$$GET1^DIQ(123,SDRIEN_",",8,"I")=SDPDC ;never update file 123 if CPRS STATUS is DISCONTINUED
+32 ;Q:$$GET1^DIQ(123,SDRIEN_",",8,"I")=SDPCM ;never update file 123 if CPRS STATUS is COMPLETE
+33 SET SDECNOTE=$GET(SDECNOTE)
+34 ;it is possible to have multiple scheduled activities; make sure there is not already a SCHEDULED activity
+35 ;S SDI=0 F S SDI=$O(^GMR(123,SDRIEN,40,SDI)) Q:SDI'>0 D Q:+SDSCHEDF
+36 ;.I $P($G(^GMR(123,SDRIEN,40,SDI,0)),U,2)=SDSCHED S SDSCHEDF=1 Q
+37 ;Q:+SDSCHEDF
+38 ;*zeb 12/13/17 679 don't use $E to remove seconds
SET SDDT=$$NOW^XLFDT()
+39 ;
+40 ; Replaced with call to SDCNSLT below. wtc/zeb 3.21.18 patch 686 ;
+41 ;
+42 ;S SDFDA(123.02,"+1,"_SDRIEN_",",.01)=SDDT ;ICR 6185
+43 ;S SDFDA(123.02,"+1,"_SDRIEN_",",1)=$S(SDACT=1:SDSCHED,SDACT=2:SDSTAT,1:"") ;ICR 6185
+44 ;S SDFDA(123.02,"+1,"_SDRIEN_",",2)=SDDT ;ICR 6185
+45 ;S SDFDA(123.02,"+1,"_SDRIEN_",",3)=SDPROV ;ICR 6185
+46 ;S SDFDA(123.02,"+1,"_SDRIEN_",",4)=SDUSR ;ICR 6185
+47 ;D UPDATE^DIE("","SDFDA","SDIEN")
+48 SET SDTXT=""
+49 ;MGH modified to add in note text and appointment data
+50 IF SDACT=1
Begin DoDot:1
+51 ;
+52 ; Disabled lines below because they exist in SDCNSLT.
+53 ; wtc/zeb 3.22.18 patch 686
+54 ;
+55 ;S SDTXT(1)=$P($G(^SDEC(409.831,+SDECRES,0)),U,1)_" Consult Appt. on "_SAVESTRT
+56 ;I SDECNOTE'="" S SDTXT(2)=SDECNOTE
+57 ;
NEW %DT,X,SD,TMPYCLNC
+58 ;
+59 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+60 ;
+61 ;
SET SD=$$NETTOFM^SDECDATE(SAVESTRT,"Y","N")
+62 ;S X=SAVESTRT,%DT="T" D ^%DT S SD=Y ;
+63 ;
SET TMPYCLNC=$PIECE($GET(^SDEC(409.831,+SDECRES,0)),U,4)
IF TMPYCLNC'=""
SET TMPYCLNC=TMPYCLNC_U_$PIECE(^SC(TMPYCLNC,0),U,1)
+64 ; Changed "" to SDECNOTE - wtc 686 11/7/2018
DO EDITCS^SDCNSLT(SD,SDECNOTE,TMPYCLNC,SDRIEN)
End DoDot:1
+65 IF SDACT=2
Begin DoDot:1
+66 ;
+67 ; Disabled lines below because they exist in SDCNSLT.
+68 ; wtc/zeb 3.22.18 patch 686
+69 ;
+70 ;S SDECTYP=$G(SDECTYP)
+71 ;S SDTXT(1)=$P($G(^SDEC(409.831,+SDECRES,0)),U,1)_" Appt. on "_SAVESTRT_" was cancelled"_$S(SDECTYP["P":" by the Patient.",SDECTYP["C":" by the Clinic.",1:".") ;alb/sat 651 include appt info
+72 ;I SDECNOTE'="" S SDTXT(2)="Remarks: "_SDECNOTE
+73 ;
NEW DFN,%DT,X,SDTTM,SDSC,SDPL
+74 SET DFN=$PIECE($GET(^GMR(123,SDRIEN,0)),U,2)
+75 ;
+76 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+77 ;
+78 ;Q:$G(SDRIEN)=""!($G(DFN)="")!(SDDFN'=DFN)!($G(SDRIEN)'=$G(SDRIEN1)) ; CLT, INC8706878, SD*5.3*694, 02/03/2020 PWC COMMENTED OUT FOR NOW UNTIL TESTED 2/3/2020
+79 ;
SET SDTTM=$$NETTOFM^SDECDATE(SAVESTRT,"Y","N")
+80 ;S X=SAVESTRT,%DT="T" D ^%DT S SDTTM=Y ;
+81 ;
SET SDSC=$PIECE($GET(^SDEC(409.831,+SDECRES,0)),U,4)
+82 ;
SET SDPL=0
FOR
SET SDPL=$ORDER(^SC(SDSC,"S",SDTTM,1,SDPL))
if 'SDPL
QUIT
if $PIECE(^(SDPL,0),U,1)=DFN
QUIT
+83 ; prevent extra comments added to 2nd cancellation - wtc 694 7/24/2019
KILL TMPD
+84 ;*zeb 686 10/30/18 send comments to consult
DO SDECCAN^SDCNSLT(SDRIEN,DFN,SDTTM,SDSC,SDECTYP,SDPL,SDECNOTE)
End DoDot:1
+85 ;
QUIT
+86 ;
+87 ; Lines below disabled by calls to SDCNSLT.
+88 ; wtc/zeb 3.22.18 patch 686
+89 ;
+90 ;I $D(SDTXT) D
+91 ;.D WP^DIE(123.02,SDIEN(1)_","_SDRIEN_",",5,"","SDTXT","SDERR") ;ICR 6185
+92 ;K SDFDA ;alb/sat 651
+93 ;set CPRS status field ICR 6185
+94 ;S SDOS=$O(^ORD(100.01,"B","SCHEDULED",0))
+95 ;S SDOA=$O(^ORD(100.01,"B","ACTIVE",0))
+96 ;I SDOS'="" D
+97 ;.;K SDFDA ;alb/sat 651 moved up
+98 ;.S SDFDA(123,SDRIEN_",",8)=$S(SDACT=1:SDOS,1:SDOA)
+99 ;.;D UPDATE^DIE("","SDFDA") ;ICR 6185 ;alb/sat 651 moved down out of IF scope
+100 ;S:+$G(SDSCHED) SDFDA(123,SDRIEN_",",9)=$S(SDACT=1:SDSCHED,1:SDSTAT) ;alb/sat 651 - set LAST ACTION TAKEN ICR 4837
+101 ;D:$D(SDFDA) UPDATE^DIE("","SDFDA") ;alb/sat 651
+102 ;Q
+103 ;
EWL(WLIEN,APPDT,SDCL,SVCP,SVCPR,NOTE,SDAPPTYP) ;update SD WAIT LIST at appointment add
+1 ;INPUT:
+2 ; WLIEN = Wait List ID pointer to SD WAIT LIST file 409.3
+3 ; APPDT = Appointment date/time (Scheduled Date of appt) in fm format
+4 ; SDCL = Clinic ID pointer to HOSPITAL LOCATION file 44
+5 ; SVCP = Service Connected Percentage numeric 0-100
+6 ; SVCPR = Service Connected Priority 0:NO 1:YES
+7 ; NOTE = Comment only 1st 60 characters are used
+8 ; SDAPPTYP - (optional) Appointment type ID pointer to APPOINTMENT TYPE file 409.1
+9 ;
+10 ;all input must be verified by calling routine
+11 NEW SDDIV,SDFDA,SDSN
+12 if +$GET(SDAPPTYP)
SET SDFDA(409.3,WLIEN_",",8.7)=SDAPPTYP
+13 ;SCHEDULED DATE OF APPT = APPDT (SDECSTART)
SET SDFDA(409.3,WLIEN_",",13)=APPDT
+14 ;DATE APPT. MADE = TODAY
SET SDFDA(409.3,WLIEN_",",13.1)=$PIECE($$NOW^XLFDT,".",1)
+15 ;APPT CLINIC = SDCL (SDECSCD)
SET SDFDA(409.3,WLIEN_",",13.2)=SDCL
+16 ;APPT INSTITUTION = Get from 44 using SDCL
SET SDFDA(409.3,WLIEN_",",13.3)=$PIECE($GET(^SC(SDCL,0)),U,4)
+17 ;APPT STOP CODE = Get from 44 using SDCL
SET SDFDA(409.3,WLIEN_",",13.4)=$PIECE($GET(^SC(SDCL,0)),U,7)
+18 SET SDDIV=$PIECE($GET(^SC(SDCL,0)),U,15)
+19 SET SDSN=$SELECT(SDDIV'="":$PIECE($GET(^DG(40.8,SDDIV,0)),U,2),1:"")
+20 ;APPT STATION NUMBER
SET SDFDA(409.3,WLIEN_",",13.6)=SDSN
+21 ;APPT CLERK = Current User
SET SDFDA(409.3,WLIEN_",",13.7)=DUZ
+22 ;APPT STATUS = R:Scheduled/Kept
SET SDFDA(409.3,WLIEN_",",13.8)="R"
+23 ;SERVICE CONNECTED PERCENTAGE = SVCP (SDSVCP)
if SVCP'=""
SET SDFDA(409.3,WLIEN_",",14)=SVCP
+24 ;SERVICE CONNECTED PRIORITY = SVCPR (SDSVCPR)
if SVCPR'=""
SET SDFDA(409.3,WLIEN_",",15)=SVCPR
+25 if $GET(NOTE)'=""
SET SDFDA(409.3,WLIEN_",",25)=NOTE
+26 ;EWL ENROLLEE STATUS = U:UNDETERMINED
SET SDFDA(409.3,WLIEN_",",27)="U"
+27 ;EWL ENROLLEE DATABASE FILE = 0:NONE
SET SDFDA(409.3,WLIEN_",",27.2)=0
+28 ;EDITING USER = Current User
SET SDFDA(409.3,WLIEN_",",28)=DUZ
+29 DO UPDATE^DIE("","SDFDA")
+30 QUIT
+31 ;
ERROR ;
+1 DO ERR1("Error")
+2 QUIT
+3 ;
ERR1(SDECERR) ;Error processing
+1 SET SDECI=SDECI+1
+2 SET ^TMP("SDEC",$JOB,SDECI)=SDECERR_$CHAR(30)
+3 SET SDECI=SDECI+1
+4 SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(31)
+5 QUIT
