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

SDEC07A.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified
  1. ;References made to ICR #6185 and #4837
  1. ;
  1. ; ICR
  1. ; ---
  1. ; 4837 - #123 Request/Consultation
  1. ; 7024 - #40.8 Medical Center Division
  1. ;
  1. Q
  1. ;
  1. 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
  1. ; .SDECY = returned pointer to OVERBOOK data
  1. ; SDCL = clinic code - pointer to Hospital Location file ^SC
  1. ; NSDT = date/time of new appointment
  1. ; SDECRES = resource to check for overbook
  1. N %DT,AP,SDECI,OB,SDBK,OBCNT,OBMAX,SDCLN,SDCLRES,SDCLSL,SDCNT,SDRET,SDT,SDTD,SDTE,X,Y
  1. N SD30,SDARR,OBCNTSUM
  1. S OBCNTSUM=0
  1. ; SDTD = new schedule Date only in FM format
  1. ; SDT = loop value for $o through schedules
  1. ; SDTE = end of loop schedule
  1. ; NSDT = new appointment schedule Date/Time will be converted to FM format
  1. S SDECI=0
  1. S SDECY="^TMP(""SDEC"","_$J_")"
  1. K @SDECY
  1. S @SDECY@(0)="T00020ERRORID"_$C(30)
  1. ;check for valid Hospital location
  1. I '+SDCL D ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.") Q
  1. I '$D(^SC(SDCL,0)) D ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.") Q
  1. ;check for valid resource ID
  1. I '+SDECRES D ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.") Q
  1. I '$D(^SDEC(409.831,SDECRES,0)) D ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.") Q
  1. ;check for valid DATE/TIME
  1. ;
  1. ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
  1. ;
  1. ;S %DT="T"
  1. ;S X=NSDT
  1. ;D ^%DT ; GET FM FORMAT FOR APPOINTMENT DATE/TIME
  1. ;S NSDT=Y
  1. S NSDT=$$NETTOFM^SDECDATE(NSDT,"Y","N") ;
  1. I NSDT=-1 D ERR1("Invalid Appointment Date.") Q
  1. S SDTD=$P(NSDT,".")
  1. ; data header
  1. ; OVERBOOK 0=not overbooked; 1=overbooked
  1. S @SDECY@(0)="T00020OVERBOOK"_$C(30)
  1. ;get allowed number of overbookings for clinic
  1. S SDCLSL=$G(^SC(SDCL,"SL"))
  1. S OBMAX=$P(SDCLSL,U,7)
  1. I '+OBMAX S (OBCNT,OBMAX)=0 G XIT
  1. N SDAB,SLOTSIZE
  1. S SDAB="^TMP("_$J_",""SDEC"",""BLKS"")"
  1. S SLOTSIZE="^TMP("_$J_",""SDEC"",""SLOTSIZE"")"
  1. K @SDAB,@SLOTSIZE
  1. ;get original slot sizes
  1. D GETSLOTS^SDEC04(SLOTSIZE,SDECRES,SDTD,SDTD_".2359")
  1. ;get current appt availability
  1. D GETSLOTS^SDEC57(SDAB,SDECRES,SDTD,SDTD_".2359")
  1. N IDX,SDR,SDSTART,SDSTOP,SDSLOTS,XX,IDX2,YY
  1. ;restore original slot sizes into appts slots
  1. S IDX="" F S IDX=$O(@SLOTSIZE@(IDX)) Q:'IDX D
  1. .S XX=@SLOTSIZE@(IDX)
  1. .S SDSTART=$P(XX,U,2),SDSTOP=$P(XX,U,3),SDSLOTS=$P(XX,U,4)
  1. .S IDX2="" F S IDX2=$O(@SDAB@(IDX2)) Q:'IDX2 D
  1. ..S YY=@SDAB@(IDX2)
  1. ..S:($P(YY,U,2)'<SDSTART)&($P(YY,U,3)'>SDSTOP) $P(@SDAB@(IDX2),U,4)=SDSLOTS
  1. ;find overbooks
  1. S IDX="" F S IDX=$O(@SDAB@(IDX)) Q:IDX="" D
  1. .S XX=@SDAB@(IDX)
  1. .S SDSTART=$P(XX,U,2),SDSTOP=$P(XX,U,3),SDSLOTS=$P(XX,U,4)
  1. .;loop thru schedule
  1. .; SDBK(<appt time>,<appt end time>)=counter starting at 0
  1. .K SDBK ;overbook counter array
  1. .S SDRET="" D CRSCHED^SDEC(.SDRET,SDECRES,SDSTART,SDSTOP)
  1. .K SDARR
  1. .S SD30=1,SDCNT=0,SDT=0 F S SDT=$O(@SDRET@(SDT)) Q:SDT="" D
  1. ..S SDR=$G(@SDRET@(SDT))
  1. ..I $P(SDR,U,1)[$c(30) S SD30=1 Q
  1. ..Q:SD30'=1
  1. ..S SDCNT=SDCNT+1
  1. ..S SDARR($P(SDR,U,1))=""
  1. ..S SD30=0
  1. .S SDCNT=0 F S SDCNT=$O(SDARR(SDCNT)) Q:SDCNT="" D
  1. ..S SDR=$G(^SDEC(409.84,+SDCNT,0))
  1. ..S SDT=$P(SDR,U,1)
  1. ..S SDTE=$P(SDR,U,2)
  1. ..Q:$P(SDR,U,12)]"" ;don't count cancelled appts
  1. ..;if time ranges overlap, add to SDBK array
  1. ..I (SDTE>SDT)&(((SDT'<SDSTART)&(SDT<SDSTOP))!((SDTE>SDSTART)&(SDTE'>SDSTOP))!((SDT'>SDSTART)&(SDTE'<SDSTOP))) D
  1. ...D CKOB(SDT,SDTE,.SDBK)
  1. ..;;D CKOB($P(SDT,".")_".0000",$P(SDTE,".")_".2359",.SDBK)
  1. .S OBCNT=$$CNTOB(.SDBK,SDECRES,SDTD,OBMAX,SDAB)
  1. .S OBCNTSUM=OBCNTSUM+OBCNT
  1. .K @SDRET,SDBK
  1. XIT ;
  1. S SDECI=SDECI+1
  1. S @SDECY@(SDECI)=$S(OBCNTSUM<OBMAX:"YES",1:"NO")
  1. S SDECI=SDECI+1
  1. S @SDECY@(SDECI)=$C(30)
  1. S SDECI=SDECI+1
  1. S @SDECY@(SDECI)=$C(31)
  1. Q
  1. ;
  1. ;find appointment in SDEC APPOINTMENT file
  1. SDECAP(SDECSDT,DFN) ;
  1. N SDECAPN,SDECRES,ID
  1. S SDECRES=0
  1. S ID=0
  1. F S ID=$O(^SDEC(409.84,"B",SDECSDT,ID)) Q:ID'>0 Q:SDECRES'=0 D
  1. . S SDECAPN=$G(^SDEC(409.84,ID,0))
  1. . I $P(SDECAPN,U,5)=DFN S SDECRES=$P(SDECAPN,U,7)
  1. Q SDECRES
  1. ;
  1. ;check if appointment start/stop is in range of an existing appointment
  1. CKOB(START,STOP,SDBK) ;called internally
  1. ; START = appointment start date/time in FM format
  1. ; STOP = appointment stop date/time in FM format
  1. ; .SDBK = bookings Array - SDBK(<appt time>,<appt end time>)=counter starting at 0
  1. N B,E,OB,OBF
  1. S OBF=0
  1. S B=""
  1. F S B=$O(SDBK(B)) Q:B'>0 D Q:+OBF
  1. . S E="" F S E=$O(SDBK(B,E)) Q:E'>0 D Q:+OBF
  1. . . S OB=SDBK(B,E)
  1. . . S OBF=1
  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))
  1. . . ;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)))
  1. . . I OBF S SDBK(B,E)=(OB+1)
  1. I 'OBF S SDBK(START,STOP)=1
  1. ;
  1. Q
  1. ;
  1. ;count overbookings
  1. CNTOB(SDBK,SDECRES,SDTD,OBMAX,SDAB) ;called internally
  1. N AB,ABF,ABN,CNT,BK,SLOTS,B,E
  1. S BK=""
  1. S CNT=0
  1. S B="" F S B=$O(SDBK(B)) Q:B="" D Q:CNT'<OBMAX
  1. . S E="" F S E=$O(SDBK(B,E)) Q:E="" D Q:CNT'<OBMAX
  1. . . S BK=SDBK(B,E)
  1. . . Q:'+BK
  1. . . S SLOTS=$$SLOTS(B,E,SDAB) ;find access block
  1. . . I '+SLOTS S CNT=CNT+BK
  1. . . E S BK=BK-SLOTS S:BK<0 BK=0 S CNT=CNT+BK
  1. Q CNT
  1. SLOTS(B,E,SDAB) ;find access block
  1. N ABF,ABN,SDI,SLOTS
  1. S SLOTS=""
  1. S SDI=0 F S SDI=$O(@SDAB@(SDI)) Q:SDI'>0 D Q:+ABF
  1. .S ABN=@SDAB@(SDI)
  1. .S ABF=((B'<$P(ABN,U,2))&(B<$P(ABN,U,3)))!((E>$P(ABN,U,2))&(E'>$P(ABN,U,3)))
  1. .S:ABF SLOTS=+$P(ABN,U,4)
  1. Q SLOTS
  1. ;
  1. REQSET(SDRIEN,SDPROV,SDUSR,SDACT,SDECTYP,SDECNOTE,SAVESTRT,SDECRES,SDDFN) ;add SCHEDULED activity to REQUEST/CONSULTATION file
  1. ;INPUT:
  1. ; SDRIEN - (required) pointer to RFEQUEST/CONSULTATION file 123
  1. ; SDPROV - (required) Provider pointer to NEW PERSON
  1. ; SDUSR - (optional) User that entered appointment pointer to NEW PERSON
  1. ; SDACT - (required) ACTIVITY type to add 1=SCHEDULED 2=STATUS CHANGE
  1. ; SDECTYP - (required if SDACT=2) appointment Status valid values:
  1. ; C=CANCELLED BY CLINIC
  1. ; PC=CANCELLED BY PATIENT
  1. ; SDECNOTE - Comments from Appointment
  1. ; SAVESTRT - Appointment time in external format ;alb/sat 651 corrected comment
  1. ; SDECRES - Appointment Resource
  1. N SDDT,SDFDA,SDI,SDIEN,SDOA,SDOS,SDPDC,SDSCHED,SDSCHEDF,SDSTAT,SDTXT,SDERR,Y,SDPCM
  1. S SDACT=$G(SDACT)
  1. S SAVESTRT=$G(SAVESTRT)
  1. S SDECRES=$G(SDECRES)
  1. Q:"12"'[SDACT
  1. S SDSCHEDF=0
  1. S SDUSR=$G(SDUSR)
  1. S:SDUSR="" SDUSR=DUZ
  1. S:'$D(^VA(200,+SDUSR,0)) SDUSR=DUZ ;take this out
  1. S SDSCHED=$$GETIEN^SDEC51("SCHEDULED")
  1. S SDSTAT=$$GETIEN^SDEC51("STATUS CHANGE")
  1. S SDPDC=$O(^ORD(100.01,"B","DISCONTINUED",0))
  1. ;ajf ; Check for completed Consult
  1. S SDPCM=$O(^ORD(100.01,"B","COMPLETE",0))
  1. I SDACT=1,SDSCHED="" Q
  1. I SDACT=2,SDSTAT="" Q
  1. ;ajf ; Check for completed Consult
  1. S SDCPS=$$GET1^DIQ(123,SDRIEN_",",8,"I")
  1. Q:SDCPS=SDPDC!(SDCPS=SDPCM)
  1. ;Q:$$GET1^DIQ(123,SDRIEN_",",8,"I")=SDPDC ;never update file 123 if CPRS STATUS is DISCONTINUED
  1. ;Q:$$GET1^DIQ(123,SDRIEN_",",8,"I")=SDPCM ;never update file 123 if CPRS STATUS is COMPLETE
  1. S SDECNOTE=$G(SDECNOTE)
  1. ;it is possible to have multiple scheduled activities; make sure there is not already a SCHEDULED activity
  1. ;S SDI=0 F S SDI=$O(^GMR(123,SDRIEN,40,SDI)) Q:SDI'>0 D Q:+SDSCHEDF
  1. ;.I $P($G(^GMR(123,SDRIEN,40,SDI,0)),U,2)=SDSCHED S SDSCHEDF=1 Q
  1. ;Q:+SDSCHEDF
  1. S SDDT=$$NOW^XLFDT() ;*zeb 12/13/17 679 don't use $E to remove seconds
  1. ;
  1. ; Replaced with call to SDCNSLT below. wtc/zeb 3.21.18 patch 686 ;
  1. ;
  1. ;S SDFDA(123.02,"+1,"_SDRIEN_",",.01)=SDDT ;ICR 6185
  1. ;S SDFDA(123.02,"+1,"_SDRIEN_",",1)=$S(SDACT=1:SDSCHED,SDACT=2:SDSTAT,1:"") ;ICR 6185
  1. ;S SDFDA(123.02,"+1,"_SDRIEN_",",2)=SDDT ;ICR 6185
  1. ;S SDFDA(123.02,"+1,"_SDRIEN_",",3)=SDPROV ;ICR 6185
  1. ;S SDFDA(123.02,"+1,"_SDRIEN_",",4)=SDUSR ;ICR 6185
  1. ;D UPDATE^DIE("","SDFDA","SDIEN")
  1. S SDTXT=""
  1. ;MGH modified to add in note text and appointment data
  1. I SDACT=1 D
  1. .;
  1. .; Disabled lines below because they exist in SDCNSLT.
  1. .; wtc/zeb 3.22.18 patch 686
  1. .;
  1. .;S SDTXT(1)=$P($G(^SDEC(409.831,+SDECRES,0)),U,1)_" Consult Appt. on "_SAVESTRT
  1. .;I SDECNOTE'="" S SDTXT(2)=SDECNOTE
  1. . N %DT,X,SD,TMPYCLNC ;
  1. .;
  1. .; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
  1. .;
  1. . S SD=$$NETTOFM^SDECDATE(SAVESTRT,"Y","N") ;
  1. . ;S X=SAVESTRT,%DT="T" D ^%DT S SD=Y ;
  1. . S TMPYCLNC=$P($G(^SDEC(409.831,+SDECRES,0)),U,4) I TMPYCLNC'="" S TMPYCLNC=TMPYCLNC_U_$P(^SC(TMPYCLNC,0),U,1) ;
  1. . D EDITCS^SDCNSLT(SD,SDECNOTE,TMPYCLNC,SDRIEN) ; Changed "" to SDECNOTE - wtc 686 11/7/2018
  1. I SDACT=2 D
  1. .;
  1. .; Disabled lines below because they exist in SDCNSLT.
  1. .; wtc/zeb 3.22.18 patch 686
  1. .;
  1. .;S SDECTYP=$G(SDECTYP)
  1. .;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
  1. .;I SDECNOTE'="" S SDTXT(2)="Remarks: "_SDECNOTE
  1. . N DFN,%DT,X,SDTTM,SDSC,SDPL ;
  1. . S DFN=$P($G(^GMR(123,SDRIEN,0)),U,2)
  1. .;
  1. .; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
  1. .;
  1. . ;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
  1. . S SDTTM=$$NETTOFM^SDECDATE(SAVESTRT,"Y","N") ;
  1. . ;S X=SAVESTRT,%DT="T" D ^%DT S SDTTM=Y ;
  1. . S SDSC=$P($G(^SDEC(409.831,+SDECRES,0)),U,4) ;
  1. . S SDPL=0 F S SDPL=$O(^SC(SDSC,"S",SDTTM,1,SDPL)) Q:'SDPL Q:$P(^(SDPL,0),U,1)=DFN ;
  1. . K TMPD ; prevent extra comments added to 2nd cancellation - wtc 694 7/24/2019
  1. . D SDECCAN^SDCNSLT(SDRIEN,DFN,SDTTM,SDSC,SDECTYP,SDPL,SDECNOTE) ;*zeb 686 10/30/18 send comments to consult
  1. Q ;
  1. ;
  1. ; Lines below disabled by calls to SDCNSLT.
  1. ; wtc/zeb 3.22.18 patch 686
  1. ;
  1. ;I $D(SDTXT) D
  1. ;.D WP^DIE(123.02,SDIEN(1)_","_SDRIEN_",",5,"","SDTXT","SDERR") ;ICR 6185
  1. ;K SDFDA ;alb/sat 651
  1. ;set CPRS status field ICR 6185
  1. ;S SDOS=$O(^ORD(100.01,"B","SCHEDULED",0))
  1. ;S SDOA=$O(^ORD(100.01,"B","ACTIVE",0))
  1. ;I SDOS'="" D
  1. ;.;K SDFDA ;alb/sat 651 moved up
  1. ;.S SDFDA(123,SDRIEN_",",8)=$S(SDACT=1:SDOS,1:SDOA)
  1. ;.;D UPDATE^DIE("","SDFDA") ;ICR 6185 ;alb/sat 651 moved down out of IF scope
  1. ;S:+$G(SDSCHED) SDFDA(123,SDRIEN_",",9)=$S(SDACT=1:SDSCHED,1:SDSTAT) ;alb/sat 651 - set LAST ACTION TAKEN ICR 4837
  1. ;D:$D(SDFDA) UPDATE^DIE("","SDFDA") ;alb/sat 651
  1. ;Q
  1. ;
  1. EWL(WLIEN,APPDT,SDCL,SVCP,SVCPR,NOTE,SDAPPTYP) ;update SD WAIT LIST at appointment add
  1. ;INPUT:
  1. ; WLIEN = Wait List ID pointer to SD WAIT LIST file 409.3
  1. ; APPDT = Appointment date/time (Scheduled Date of appt) in fm format
  1. ; SDCL = Clinic ID pointer to HOSPITAL LOCATION file 44
  1. ; SVCP = Service Connected Percentage numeric 0-100
  1. ; SVCPR = Service Connected Priority 0:NO 1:YES
  1. ; NOTE = Comment only 1st 60 characters are used
  1. ; SDAPPTYP - (optional) Appointment type ID pointer to APPOINTMENT TYPE file 409.1
  1. ;
  1. ;all input must be verified by calling routine
  1. N SDDIV,SDFDA,SDSN
  1. S:+$G(SDAPPTYP) SDFDA(409.3,WLIEN_",",8.7)=SDAPPTYP
  1. S SDFDA(409.3,WLIEN_",",13)=APPDT ;SCHEDULED DATE OF APPT = APPDT (SDECSTART)
  1. S SDFDA(409.3,WLIEN_",",13.1)=$P($$NOW^XLFDT,".",1) ;DATE APPT. MADE = TODAY
  1. S SDFDA(409.3,WLIEN_",",13.2)=SDCL ;APPT CLINIC = SDCL (SDECSCD)
  1. S SDFDA(409.3,WLIEN_",",13.3)=$P($G(^SC(SDCL,0)),U,4) ;APPT INSTITUTION = Get from 44 using SDCL
  1. S SDFDA(409.3,WLIEN_",",13.4)=$P($G(^SC(SDCL,0)),U,7) ;APPT STOP CODE = Get from 44 using SDCL
  1. S SDDIV=$P($G(^SC(SDCL,0)),U,15)
  1. S SDSN=$S(SDDIV'="":$P($G(^DG(40.8,SDDIV,0)),U,2),1:"")
  1. S SDFDA(409.3,WLIEN_",",13.6)=SDSN ;APPT STATION NUMBER
  1. S SDFDA(409.3,WLIEN_",",13.7)=DUZ ;APPT CLERK = Current User
  1. S SDFDA(409.3,WLIEN_",",13.8)="R" ;APPT STATUS = R:Scheduled/Kept
  1. S:SVCP'="" SDFDA(409.3,WLIEN_",",14)=SVCP ;SERVICE CONNECTED PERCENTAGE = SVCP (SDSVCP)
  1. S:SVCPR'="" SDFDA(409.3,WLIEN_",",15)=SVCPR ;SERVICE CONNECTED PRIORITY = SVCPR (SDSVCPR)
  1. S:$G(NOTE)'="" SDFDA(409.3,WLIEN_",",25)=NOTE
  1. S SDFDA(409.3,WLIEN_",",27)="U" ;EWL ENROLLEE STATUS = U:UNDETERMINED
  1. S SDFDA(409.3,WLIEN_",",27.2)=0 ;EWL ENROLLEE DATABASE FILE = 0:NONE
  1. S SDFDA(409.3,WLIEN_",",28)=DUZ ;EDITING USER = Current User
  1. D UPDATE^DIE("","SDFDA")
  1. Q
  1. ;
  1. ERROR ;
  1. D ERR1("Error")
  1. Q
  1. ;
  1. ERR1(SDECERR) ;Error processing
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC",$J,SDECI)=SDECERR_$C(30)
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC",$J,SDECI)=$C(31)
  1. Q