- 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 Jan 18, 2025@03:51:06 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