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

SDESCLNSETAVAIL.m

Go to the documentation of this file. 
  1. SDESCLNSETAVAIL ;ALB/TAW,KML,MGD,LAB,BLB,TJB - SET CLINIC AVAILABILITY ;JUN 03, 2024
  1.  ;;5.3;Scheduling;**800,803,805,809,818,820,833,842,843,868,880**;Aug 13, 1993;Build 5
  1.  ;;Per VHA Directive 6402, this routine should not be modified
  1.  ;
  1. SETCLINAVAIL(RETURN,SDCLINIC,DATES,TIMES,SLOTS,SDEAS) ;INICSET2(.POP,SDIEN,.FDA,.SDCLINIC,.PROVIDER,.DIAGNOSIS,.SPECIALINSTRUCT,.PRIVLIAGEDUSER)
  1.  ; Input:
  1.  ; SDCLIN - [REQ] Name or IEN from file 44
  1.  ; DATES - [opt] String of dates in ISO8601 or FM format separated by a ;
  1.  ; TIMES - [opt] String of time frames in military format separated by a ;
  1.  ;   ex: 0700-1030;1030-1400
  1.  ; SLOTS - [REQ] String of integers separated by a ;
  1.  ;  The number of TIMES and SLOTS must match
  1.  ; SDEAS - [Optional] - Enterprise Appointment Scheduling (EAS) Tracking Number
  1.  ;
  1.  ;if times and slots are empty, logic will remove availability
  1.  ;
  1.  N POP,SDAVAIL,I,SDDOWNUM,DOWNUM,EOF,SDTOTALSLOTS,SDDISPPERHR,SDCLINSTARTHR,SDSOH,SLT,IEN,SDCLINDATA,SDSLOTS,SDTIME,SDDATE,TMPINDX
  1.  N SDRETURN,APPTCNT,ERRARRAY
  1.  S (POP,SDTOTALSLOTS,APPTCNT)=0
  1.  D VALIDATE
  1.  I 'POP D CREATE(SDCLINIC,SDCLINSTARTHR,SLT,SDDOWNUM)
  1.  I 'POP S SDRETURN("ClinicAvailability","Create")="Pattern Filed"
  1.  D BUILDER
  1.  K ERRARRAY
  1.  Q
  1.  ;
  1. VALIDATE ;
  1.  S SDCLINIC=$G(SDCLINIC)
  1.  I SDCLINIC'="",'$D(^SC(SDCLINIC,0)) D ERRLOG(19) Q
  1.  I SDCLINIC="" D ERRLOG(18) Q
  1.  ;
  1.  S IEN=SDCLINIC_","
  1.  D GETS^DIQ(44,IEN,"1912;1914;1917;1918.5","IE","SDCLINDATA","SDMSG")
  1.  S SLT=$G(SDCLINDATA(44,IEN,1912,"I"))
  1.  I SLT=""  D ERRLOG(115)
  1.  I (SLT<10)!(SLT>240)!(SLT?.E1"."1N.N)!($S('(SLT#10):0,'(SLT#15):0,1:1)) D ERRLOG(116)
  1.  S SDDISPPERHR=$G(SDCLINDATA(44,IEN,1917,"I"))
  1.  S SDCLINSTARTHR=$G(SDCLINDATA(44,IEN,1914,"I"),"")
  1.  I SDCLINSTARTHR="" S SDCLINSTARTHR=8
  1.  ;
  1.  N STARTTIME,ENDTIME,TMPTIMES
  1.  S TIMES=$G(TIMES)
  1.  S SLOTS=$G(SLOTS)
  1.  I ((TIMES="")&(SLOTS'=""))!((TIMES'="")&(SLOTS="")) D ERRLOG(52,"Times and slots mismatch")
  1.  I 'POP,$L(TIMES,";")'=$L(SLOTS,";") D ERRLOG(52,"Times and slots mismatch")
  1.  ;
  1.  I $P(DATES,"9999999",1)="" D ERRLOG(52,"Date Missing.  Must have a date indicated.") Q
  1.  I $P(DATES,"9999999",2)'="" D ERRLOG(52,"Indefinite date indicator must be last") Q
  1.  ;
  1.  I TIMES'="" D
  1.  .F I=1:1:$L(TIMES,";") Q:POP  D
  1.  ..S SDTIME=$P(TIMES,";",I)
  1.  ..I SDTIME'?4N1"-"4N D ERRLOG(52,"Invalid time format") Q
  1.  ..I $P(SDTIME,"-",2)>2400 D ERRLOG(52,"Invalid time format") Q
  1.  ..S STARTTIME=$P(SDTIME,"-",1)
  1.  ..S ENDTIME=$P(SDTIME,"-",2)
  1.  ..I +STARTTIME'<+ENDTIME D ERRLOG(52,"Invalid time format") Q
  1.  ..;Do not allow overlapping time frames
  1.  ..I $D(TIMES(STARTTIME)) D ERRLOG(52,"Existing entry with same start time") Q
  1.  ..; STARTTIME can not fall within the previous segment
  1.  ..S TMPINDX=$O(TIMES(STARTTIME),-1)
  1.  ..I TMPINDX D  Q:POP
  1.  ...S TMPTIMES=TIMES(TMPINDX)
  1.  ...I +$P(TMPTIMES,"-",2)>+STARTTIME D ERRLOG(52,"Start time overlaps existing segment") Q
  1.  ..; ENDTIME can not fall within a prior segment
  1.  ..S TMPINDX=$O(TIMES(ENDTIME),-1)
  1.  ..I TMPINDX D
  1.  ...S TMPTIMES=TIMES(TMPINDX)
  1.  ...;Current start time is = or > than previous end time
  1.  ...I STARTTIME'<+$P(TMPTIMES,"-",2) Q
  1.  ...; ENDTIME falls within and existing segment
  1.  ...I +$P(TMPTIMES,"-",1)<+ENDTIME D ERRLOG(52,"End time overlaps existing segment") Q
  1.  ...; An existing segment falls within STARTTIME and ENDTIME
  1.  ...I +$P(TMPTIMES,"-",2)<+ENDTIME D ERRLOG(52,"End time overlaps existing segment") Q
  1.  ..; Is this time segment consistent with slot duration
  1.  ..I '$$CHECKDURATION(STARTTIME,ENDTIME,SLT) D ERRLOG(52,"Time span not consistent with appointment length")
  1.  ..;
  1.  ..S SDSLOTS=+$P(SLOTS,";",I)
  1.  ..I SDSLOTS<1!(SDSLOTS>26) D ERRLOG(125) Q
  1.  ..S TIMES(STARTTIME)=SDTIME_"^"_SDSLOTS
  1.  ..S SDTOTALSLOTS=SDTOTALSLOTS+SDSLOTS
  1.  .I 'POP,$D(TIMES)'>1 D ERRLOG(52,"No valid time segments passed in")
  1.  .;Can't start prior to clinic opening
  1.  .I 'POP,+$O(TIMES(""))<(SDCLINSTARTHR*100) D ERRLOG(52,"Appointments can not start prior to clinic opening")
  1.  ;
  1.  S DATES=$G(DATES)
  1.  S SDDATE=$P(DATES,";",1)
  1.  I SDDATE="" D ERRLOG(45)
  1.  I SDDATE'="" D
  1.  .I SDDATE'?7N S SDDATE=$$ISOTFM^SDAMUTDT(SDDATE)  ;vse-2396
  1.  .I SDDATE'?7N D ERRLOG(46) Q
  1.  .I SDDATE<DT D ERRLOG(71) Q
  1.  .S SDDOWNUM=$$DOW^XLFDT(SDDATE,1),DATES(SDDATE)=""
  1.  .;D GETAPPT
  1.  .;I $G(ERRARRAY(SDDATE))=1 D ERRLOG(52,"Pending appointments must be cancelled")
  1.  ;
  1.  Q:POP
  1.  I 'POP,$D(DATES)'>1 D ERRLOG(52,"No valid dates passed in") Q
  1.  ;
  1.  S EOF=0
  1.  F I=2:1:$L(DATES,";") D  Q:EOF
  1.  .S SDDATE=$P(DATES,";",I)
  1.  .Q:'SDDATE
  1.  .I SDDATE=9999999 S DATES(SDDATE)="",EOF=1 Q  ;Indefinitely
  1.  .I SDDATE'?7N S SDDATE=$$ISOTFM^SDAMUTDT(SDDATE)  ;vse-2396
  1.  .I SDDATE'?7N D ERRLOG(46) Q
  1.  .I SDDATE<DT D ERRLOG(71)
  1.  .I $G(SDDOWNUM)'=$$DOW^XLFDT(SDDATE,1) D ERRLOG(52,"Schedule days do not match") S EOF=1
  1.  .S DATES(SDDATE)=""
  1.  .;D GETAPPT
  1.  .;I $G(ERRARRAY(SDDATE))=1 D ERRLOG(52,"Pending appointments must be cancelled")
  1.  .;I $D(SDRETURN("ClinicAvailability","Appt")) D ERRLOG(52,"Pending appointments must be cancelled")
  1.  ;
  1.  S SDEAS=$G(SDEAS,"")
  1.  I $L(SDEAS) S SDEAS=$$EASVALIDATE^SDESUTIL(SDEAS)
  1.  I SDEAS=-1 D ERRLOG(142)
  1.  Q
  1. GETAPPT ;Check if there are any open appts for this date
  1.  N JSON,SDESERR,A,X
  1.  S X=""
  1.  D APPTBYCLINIC^SDESAPPT(.JSON,SDCLINIC,SDDATE_"@0001",SDDATE_"@2359")
  1.  ;D DECODE^XLFJSON("JSON","A","SDESERR") ;removed the decode
  1.  ;Remove any canceled appt
  1.  F  S X=$O(JSON("Appt",X)) Q:'X  D
  1.  .I $P(JSON("Appt",X,"Status"),"CANCELLED",2)'="" Q
  1.  .S APPTCNT=APPTCNT+1
  1.  .M SDRETURN("ClinicAvailability","Appt",APPTCNT)=JSON("Appt",X)
  1.  .S ERRARRAY(SDDATE)=1
  1.  Q
  1. CHECKDURATION(T1,T2,SLT) ;Ensure the appointment lengths align with the time segment
  1.  N H1,H2,M1,M2,SDL,SD1
  1.  S H1=$E(T1,1,2),H2=$E(T2,1,2),M1=$E(T1,3,4),M2=$E(T2,3,4)
  1.  S:M1=0 M1=60,H1=H1-1
  1.  S:M2=0 M2=60,H2=H2-1
  1.  S SD1=M2-M1+((H2-H1)*60),SDL=SD1\SLT
  1.  I SDL*SLT'=+SD1 Q 0
  1.  Q 1
  1.  ;
  1. CREATE(DA,STARTDAY,SLT,DOW) ;
  1.  ;DA = Clinic IEN  (SDCLINIC)
  1.  ;SLT - Appointment length
  1.  N D0,X,CNT,STARTTIME,T1,T2,NSL,CTR,DR,HY,MAX,SC,SD,SDREB,SDSTRTDT,SDZQ,ST,STR,Y1,INDEFINITELY,STIME
  1.  N LT,H1,H2,M1,M2,SDTOP,SDREACT,X,SI,ZDX,DH,DO,D,Y,SDEL,HSI,SDJJ,HHY,SDIN,SDRE,SDRE1,I,OK,X1,X2,A,SDA1
  1.  S STARTTIME=STARTDAY*100
  1.  S (HSI,SI)=$G(SDDISPPERHR,4)
  1.  S:SI=1 SI=4,HSI=1
  1.  S:SI=2 SI=4,HSI=2
  1.  ;
  1.  ;S DIC(0)="MAQEZL",(DIC,DIE)="^SC("_DA_",""T"",",DIC("W")=$P($T(DOW),";",3)
  1.  S:'$D(^SC(DA,"T",0)) ^SC(DA,"T",0)="^44.002D"
  1.  ;
  1.  S D0=""
  1.  F  S (SD,D0)=$O(DATES(D0)) Q:D0=""  D  Q:POP
  1.  .Q:D0?7"9"
  1.  .S (CNT,INDEFINITELY)=0
  1.  .I $O(DATES(D0))?7"9" S INDEFINITELY=1
  1.  .S STARTTIME=""
  1.  .F  S STARTTIME=$O(TIMES(STARTTIME)) Q:STARTTIME=""  D  Q:POP
  1.  ..S X=TIMES(STARTTIME)
  1.  ..S T2=$P($P(X,"^",1),"-",2)
  1.  ..S NSL=$P(X,"^",2)
  1.  ..S T1=STARTTIME
  1.  ..D G3  ;Set up time slots in the T node
  1.  .;
  1.  .D:'POP G5  ;Set up pattern for the date
  1.  Q
  1.  ;
  1. G3 ;
  1.  ;
  1.  ;SDTOP ??
  1.  ;SDREACT ??
  1.  ;SDSOH - Schedule on holidays
  1.  ;SDIN - Inactivation date
  1.  ;SDRE - Reactivation date
  1.  ;
  1.  S SDTOP=1 ;????
  1.  S SDZQ=1
  1.  ;
  1.  S LT=T2,H1=$E(T1,1,2),H2=$E(T2,1,2),M1=$E(T1,3,4),M2=$E(T2,3,4)
  1.  S M2=M2-SLT
  1. G3A I M2<0 S M2=M2+60,H2=H2-1 G G3A
  1.  S:M2?1N M2="0"_M2 S:H2?1N H2="0"_H2
  1. G4 S CNT=CNT+1,^SC(DA,"T",D0,2,CNT,0)=H1_M1_"^"_NSL
  1.  S M1=M1+SLT
  1. G4A I M1>59 S M1=M1-60,H1=H1+1 G G4A
  1.  S:M1?1N M1="0"_M1 S:H1?1N H1="0"_H1
  1.  I (H1_M1)>(H2_M2) Q
  1.  G G4
  1.  Q
  1.  ;
  1. G5 ;
  1.  S SDEL=0
  1.  G:'CNT DEL1:'$D(SDREACT),DEL1:'$D(SDTOP)&$D(SDREACT)&'CNT,C^SDB
  1.  S ^SC(DA,"T",D0,0)=D0,^SC(DA,"T",D0,2,0)="^44.004A^"_CNT_"^"_CNT
  1.  S X=^SC(DA,"T",0),^SC(DA,"T",0)="^44.002D^"_D0_"^"_($P(X,"^",4)+1)
  1.  S DH=SLT*SI\60
  1.  F ZDX=CNT:0 S ZDX=$O(^SC(DA,"T",D0,2,ZDX)) Q:ZDX=""  K ^SC(DA,"T",D0,2,ZDX)
  1.  F X=0:0 S X=$O(^SC(DA,"T",D0,2,X)) Q:X=""  D
  1.  .S Y=^SC(DA,"T",D0,2,X,0)
  1.  .F D=1:1:DH S Y(Y#100*SI\60+(Y\100*SI)-(STARTDAY*SI)+D)=$S($P(Y,U,2):$E("123456789jklmnopqrstuvwxyz",$P(Y,U,2)),1:0)
  1.  S (DH,DO,X)=""
  1.  I $D(Y)=1 S SDEL=1 G D
  1.  I $D(HSI) I HSI=1!(HSI=2) D CKSI1
  1.  F Y=1:1 S DH=$D(Y(Y)),X=X_$S('DH&DO:"]",'DO&DH:"[",Y#SI=1:"|",1:" ")_$S(DH:Y(Y),1:" "),DO=DH I 'DH,$O(Y(Y))="" Q
  1.  ; CHECK WITH DARRYL & ANGELA RELATED TO NEXT LINE
  1.  K Y
  1.  I SI+SI+$L(X)>80 K ^SC(DA,"T",D0) S CNT=0,LT=$G(STIME),SDEL=0 D ERRLOG(52,"Availability string exceeds 80 characters") Q
  1.  G D
  1. CKSI1 F SDJJ=$O(Y(-1)):$S(HSI=1:4,1:2) Q:SDJJ>41  S:$D(Y(SDJJ)) HY(SDJJ)="" I '$D(Y(SDJJ)) Q:$O(Y(SDJJ))=""  S SDJJ=$O(Y(SDJJ-1))-$S(HSI=1:4,1:2)
  1.  F HHY=0:0 S HHY=$O(Y(HHY)) Q:HHY=""  I '$D(HY(HHY)) K Y(HHY)
  1.  Q
  1.  ;
  1. DEL1 S (DH,DO,X)="",SDEL=1
  1. D I $D(SDIN),SDIN>D0 S SDRE1=$S(SDRE:SDRE,1:9999999)
  1.  S DH=X,OK=0,CTR=0
  1.  S SDSOH=$S('$D(^SC(DA,"SL")):0,$P(^SC(DA,"SL"),"^",8)']"":0,1:1)
  1.  F X=D0:0 S X=+$O(^SC(DA,"T",X)) Q:X'>0  D DOW^SDM0 I Y=DOW S Y=X,DO=Y G R
  1.  I X'>0,$D(SDIN),SDIN>D0 D
  1.  .S SDRE1=$S(SDRE=0:9999999,1:SDRE)
  1.  .S X=SDIN
  1.  .F I=0:1:6 D DOW^SDM0 S:Y=DOW OK=1 Q:OK  S X1=X,X2=1 D C^%DTC Q:X>SDRE1
  1.  I OK S Y=X,DO=D0 G R
  1.  S DO=9999999
  1. R K OK
  1.  ; CHECK ON AVAILABILITY DATE W D&A THEN REVIEW G1^SDB
  1. EN1 ;
  1.  S D=D0
  1.  I 'INDEFINITELY G 1
  1.  S Y=""
  1.  I '$D(^SC(DA,"T"_DOW,D0,1)) D
  1.  .S Y=+$O(^SC(DA,"T"_DOW,D0))
  1.  .I Y>D0 S X=^SC(DA,"T"_DOW,Y,1),POP=0 D CHK1 K:'POP ^SC(DA,"T"_DOW,Y) S ^SC(DA,"T"_DOW,D0,1)=X,^SC(DA,"T"_DOW,D0,0)=D0 D TX
  1.  I Y<0,'$D(^SC(DA,"T"_DOW,D0)) S ^SC(DA,"T"_DOW,D0,1)="",^SC(DA,"T"_DOW,D0,0)=D0 D TX
  1.  S ^SC(DA,"T"_DOW,DO,1)=DH,^SC(DA,"T"_DOW,DO,0)=DO D TX
  1.  S X=D0 D B1^SDB1 S MAX=$$DAYSINFUTURE(DA,SD),SC=DA,SDSTRTDT=SD
  1.  Q:'CNT
  1.  D OVR^SDAUT1 I $G(DO)'=9999999 S SDRETURN("ClinicAvailability","DateIndefiniteScheduleEnds")=$$FMTISO^SDAMUTDT($G(DO)) Q:'SDZQ
  1.  Q
  1.  ;
  1. DAYSINFUTURE(CLINICIEN,STARTDATE) ;
  1.  N FUTUREBOOKINGNUM,FUTUREBOOKDATE,HOLIDAYFILEDATE
  1.  ;
  1.  S FUTUREBOOKINGNUM=$S($$GET1^DIQ(44,CLINICIEN,2002,"I"):$$GET1^DIQ(44,CLINICIEN,2002,"I"),1:390)
  1.  S FUTUREBOOKDATE=$$FMADD^XLFDT(STARTDATE,FUTUREBOOKINGNUM)
  1.  S HOLIDAYFILEDATE="",HOLIDAYFILEDATE=$O(^HOLIDAY("B",HOLIDAYFILEDATE),-1)
  1.  ;
  1.  I FUTUREBOOKDATE<HOLIDAYFILEDATE Q FUTUREBOOKINGNUM
  1.  Q $$FMDIFF^XLFDT(HOLIDAYFILEDATE,STARTDATE)
  1.  ;
  1. 1 I SDEL S POP=0 D APPCK I POP D DELERR G OVR
  1. 11 G:$D(^HOLIDAY(D,0))&('SDSOH) OVR
  1.  S POP=0
  1.  D:$D(SDIN) CHK2
  1.  G:POP OVR
  1.  S (POP,SDREB)=0
  1.  S %=1
  1.  D APPCK
  1.  I POP D APPERR G:(%-1) OVR S SDREB=1
  1.  S X=D,DO=X+1,^SC(DA,"ST",X,9)=D,SDREACT=1
  1.  S:'$D(^SC(DA,"ST",0)) ^SC(DA,"ST",0)="^44.005DA^^" D B1^SDB1  ;SD*567 change set of 9 node to selected date
  1. OVR ;
  1.  I D#100<22 S D=D+7 S POP=0 D:$D(SDIN) CHK2 Q
  1.  S X1=D,X2=7 D C^%DTC S D=X S POP=0 D:$D(SDIN) CHK2 Q
  1.  ;
  1. APPCK ;Are there appointments for this time?
  1.  Q
  1.  ;Temporary change appointment has already been checked above, quick fix, logic to be removed during rewrite
  1.  ;F A=D:0 S A=+$O(^SC(DA,"S",A)) Q:A'>0!(A\1-D)  F SDA1=0:0 S SDA1=+$O(^SC(DA,"S",A,1,SDA1)) Q:SDA1'>0  I $P(^SC(DA,"S",A,1,SDA1,0),"^",9)'["C" S POP=1 Q
  1.  ;Q
  1. APPERR ;
  1.  N %
  1.  W *7,!,"THERE ARE ALREADY APPOINTMENTS PENDING ON THIS DATE",!,"ARE YOU SURE YOU WANT TO CHANGE THE EXISTING AVAILABILITY" S %=2 D YN^DICN
  1.  I '% W !,"IF YOU SAY YES, THE EXISTING APPOINTMENTS MAY BECOME OVERBOOKS WHEN THE NEW AVAILABILITY IS APPLIED",!,"ANSWER YES OR NO" G APPERR
  1.  Q
  1. DELERR ;
  1.  S Y=D
  1.  W !,"... " D DT^DIQ W " HAS PENDING APPTS - DELETE AVAILABILITY NOT ALLOWED" Q
  1. CHK1 Q:'$D(SDIN)
  1.  I Y=SDIN S POP=1
  1.  Q
  1.  ;
  1. CHK2 ;
  1.  I SDIN<D,SDRE,SDRE'>D K SDIN Q
  1.  I SDIN<D,SDRE=0 S POP=1 Q
  1.  I SDIN<D,SDRE>D S POP=2,D=SDRE,X=D F I=0:1:6 D DOW^SDM0 Q:Y=DOW  S X1=D,X2=1 D C^%DTC S D=X
  1.  S Y=SDIN D DTS^SDUTL S Y1=Y,Y=SDRE1 D DTS^SDUTL W:POP=2&('CTR) !!,"    Clinic is inactive from ",Y1," to ",Y,! S:POP=2 CTR=1
  1.  Q
  1. OB ;
  1.  S SDSLOT=$E(STR,$F(STR,ST)-2)
  1.  I SDSLOT?1P,SDSLOT'?1" " S ^SC(DA,"S",DR,1,Y,"OB")="O" K SDSLOT Q
  1.  K ^SC(DA,"S",DR,1,Y,"OB"),SDSLOT
  1.  Q
  1. TX ;
  1.  S:'$D(^SC(DA,"T"_DOW,0)) ^SC(DA,"T"_DOW,0)="^44.0"_$S(DOW<4:DOW+6,DOW<6:"0"_DOW+4,1:"001")_"A^^" Q
  1.  ;
  1. ERRLOG(ERNUM,OPTIONALTXT) ;
  1.  S POP=1
  1.  D ERRLOG^SDESJSON(.SDRETURN,$G(ERNUM),$G(OPTIONALTXT))
  1.  Q
  1. BUILDER ;Convert data to JSON
  1.  N JSONERR
  1.  S JSONERR=""
  1.  D ENCODE^SDESJSON(.SDRETURN,.RETURN,.JSONERR)
  1.  Q
  1.  ;