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

SDESBLKANDMOVE1.m

Go to the documentation of this file.
  1. SDESBLKANDMOVE1 ;ALB/MGD/TAW - BLOCK AND MOVE CONT. ;Jan 21, 2022
  1. ;;5.3;Scheduling;**800,801,803,804**;Aug 13, 1993;Build 9
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. ;
  1. TOOVBCHECK(SDTOCLIEN,TODTFM,APPTARY,FN,SDECAPPTIENS,POP,SDAPPT,OVB) ; Check if new appt will be considered an overbook
  1. N OBM,SDECWKIN,SDDFN,SDECATID
  1. S SDECWKIN=""
  1. S SDECATID=$G(APPTARY(FN,SDECAPPTIENS,.13,"E")) ;WALKIN - WALKIN flag y=YES; n=NO default to NO
  1. S SDDFN=$G(APPTARY(FN,SDECAPPTIENS,.05,"I")) ;Patient ID/DFN
  1. I SDECATID=""!(SDECATID="NO") S SDECATID=$P($G(^DPT(SDDFN,"S",TODTFM,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. I SDECATID="WALKIN" S SDECWKIN=1
  1. ; check for max overbook and overbook keys. We assume yes if any check w/ user is needed.
  1. S OBM=$$OBM1^SDEC57(SDTOCLIEN,TODTFM,0,,+SDECWKIN) ; Passing MRTC (3rd param) in as 0:False
  1. I $E(OBM,1)=0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,"Overbook not allowed")
  1. ; OVB 1:should be flagged as Overbook 2:shouldn't be flagged as Overbook
  1. S OVB=$S($E(OBM,1)=2:1,1:2)
  1. Q
  1. ;
  1. PREBLOCK(FROMDTFM,FROMTIMESCALE,FROMRES,SDORGCLIEN,SDDATA44SL,SDSEGMENTS) ;
  1. ; 1st call to block original slots
  1. N SDINDX,SLOTS,MOVINGSTRT,SDECEND,EVALSTRT,EVALSTOP
  1. S EVALSTRT=$P(SDSEGMENTS(SDORGCLIEN,"F","EVALUATE"),U,1)
  1. S EVALSTOP=$P(SDSEGMENTS(SDORGCLIEN,"F","EVALUATE"),U,2)
  1. S EVALSTRT=$$PADLENGTH^SDESUTIL(EVALSTRT,"0",4,"F")
  1. ; If orig appt occupied more than 1 slot in a variable length clinic, block the additional slots
  1. S MOVINGSTRT=$P(FROMDTFM,".",1)_"."_EVALSTRT
  1. F SLOTS=1:1 D Q:EVALSTOP<=+$$PADFMTIME^SDESUTIL($P(MOVINGSTRT,".",2))
  1. .S SDECEND=$$FMADD^XLFDT(MOVINGSTRT,,,+FROMTIMESCALE)
  1. .D BLOCK($P(MOVINGSTRT,".",1),$P(MOVINGSTRT,".",2),$P(SDECEND,".",2),SDORGCLIEN,SDDATA44SL,FROMTIMESCALE)
  1. .S MOVINGSTRT=SDECEND
  1. Q
  1. ;
  1. BLOCK(SDSTDATE,SDSTTIME,SDENDTIME,SDORGCLIEN,SDDATA44SL,TIMESCALE) ; Logic copied from routine SDC
  1. N A,CANREM,DA,DFN,DH,I,FR,NOAP,P,SD,SDCNT,SDDATA0,STARTDAY,SDDFR,SDHTO,SI,ST,TO,X,Y,%
  1. S SC=SDORGCLIEN
  1. ; If the resource on the new IEN = resource on origial IEN, no need to block
  1. ; Determine timeslot equivalent
  1. S %=$S(TIMESCALE=10:6,TIMESCALE=20:3,TIMESCALE=15:4,TIMESCALE=30:2,1:1)
  1. S SI=$S(%="":4,%<3:4,%:%,1:4)
  1. S %=$P(SDDATA44SL,U,3),STARTDAY=$S($L(%):%,1:8) D NOW^%DTC S SDTIME=%
  1. S (CANREM,I)="BLOCK AND MOVE"
  1. S SD=SDSTDATE
  1. ; If Start Time = midnight set to 0001 to pass TC
  1. I $E(SDSTTIME,1,2)=24 S SDSTTIME="0001"
  1. I +SDSTTIME=0 S SDSTTIME="0001"
  1. S X=SDSTTIME_"0000",X=$E(X,1,4) D TC
  1. S FR=Y,ST=%
  1. ; If End Time = midnight set to 2359 to pass TC
  1. I $E(SDENDTIME,1,2)=24 S SDENDTIME=2359
  1. I +SDENDTIME=0 S SDENDTIME=2359
  1. S X=SDENDTIME_"0000",X=$E(X,1,4) D TC
  1. S SDHTO=X,TO=Y,SDDFR=TO-FR
  1. I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP
  1. S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1)
  1. SKIP S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO
  1. S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",+$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0)
  1. S ^SC(SC,"S",FR,0)=FR,^SC(SC,"S",FR,"MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")")
  1. D S S I=^SC(SC,"ST",SD,1),I=I_$J("",%-$L(I)),Y="" I $G(SDDFR)<100,$L(I)<77 S I=I_" " ;SD*5.3*758 - pad 4 empty spaces needed for blocks < 60 minutes
  1. F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(X<ST:DH_$E(I,X+1+SI+SI),X=%:$S(Y="[":Y,1:DH)_$E(I,X+1+SI+SI),1:$S(Y="["&(X=ST):"]",1:"X")_"X"),Y=$S(DH="]":"",DH="[":DH,1:Y),I=$E(I,1,X-1+SI+SI)_P_$E(I,X+2+SI+SI,999)
  1. S:'$F(I,"[") I5=$F(I,"X"),I=$E(I,1,(I5-2))_"["_$E(I,I5,999) K I5
  1. S DH=0,^SC(SC,"ST",SD,1)=I,FR=FR-.0001 D C Q
  1. S S ^SC(SC,"ST",SD,"CAN")=^SC(SC,"ST",SD,1) Q
  1. ;
  1. C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'<TO) K SDX Q
  1. N TDH,TMPD,DIE,DR,NODE,SDI
  1. ; SD*724 - Replace 'I' with 'SDI'
  1. F SDI=0:0 S SDI=$O(^SC(SC,"S",FR,1,SDI)) Q:SDI'>0 D
  1. .I '$D(^SC(SC,"S",FR,1,SDI,0)) I $D(^("C")) S J=FR,J2=SDI D DELETE^SDC1 K J,J2 Q ;SD*5.3*545 delete corrupt node
  1. .I '+$G(^SC(SC,"S",FR,1,SDI,0)) S J=FR,J2=SDI D DELETE^SDC1 K J,J2 Q ;SD*5.3*545 if DFN is missing delete record
  1. .Q:$P(^SC(SC,"S",FR,1,SDI,0),"^",9)="C" ;SD*5.3*758 - Quit processing if appointment already canceled.
  1. .S DFN=+^SC(SC,"S",FR,1,SDI,0),SDCNHDL=$$HANDLE^SDAMEVT(1)
  1. .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,SDI,SDCNHDL)
  1. .S $P(^SC(SC,"S",FR,1,SDI,0),"^",9)="C"
  1. .S:$D(^DPT(DFN,"S",FR,0)) NODE=^(0) ;added SD/523
  1. .Q:$P(NODE,U,1)'=SC ;added SD/523
  1. .S ^DPT("ASDCN",SC,FR,DFN)=""
  1. .S SDSC=SC,SDTTM=FR,SDPL=SDI,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478
  1. .I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1,TDH=DH,DIE="^DPT(DFN,"_"""S"""_",",DR="17///^S X=CANREM",DA=FR D ^DIE S DH=TDH D MORE
  1. .D SDEC^SDCNP0(DFN,FR,SC,"C","",$G(CANREM),SDTIME,DUZ) ;alb/sat 627
  1. G C
  1. ;
  1. MORE I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N"
  1. N SDV1
  1. S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:+$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN)
  1. ; SD*724 - set SDPL with value from SDI
  1. S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=SDI,SDRT="D" D RT^SDUTL
  1. S DH=SDH K SDH D CK1,EVT
  1. K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q
  1. CK1 S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(FR\1)) I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q
  1. Q:SDX F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q
  1. Q:SDX IF $D(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0)) S SDX=1
  1. Q:SDX K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) Q
  1. ;
  1. EVT ; -- separate tag if need to NEW vars
  1. ; -- cancel event
  1. N FR,I,SDTIME,DH,SC
  1. D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL
  1. Q
  1. ;
  1. BUILDER ;Convert data to JSON
  1. N JSONERR
  1. S JSONERR=""
  1. D ENCODE^SDESJSON(.SDAPPT,.RETURN,.JSONERR)
  1. Q
  1. ;
  1. TC N %DT S X=$$FMTE^XLFDT(SD)_"@"_X,%DT="T" D ^%DT I Y<0!(X["?") Q
  1. S X=$E($P(Y_"0000",".",2),1,4),%=$E(X,3,4),%=X\100-STARTDAY*SI+(%*SI\60)*2 I %<0 S Y=-1
  1. I %>72 S Y=-1
  1. Q
  1. ;
  1. HASPATRN(SDTOCLIEN,SDDOW,TODTFM) ;find day template pattern
  1. N SDE,SDTP
  1. S SDTP=""
  1. S SDTP=$G(^SC(SDTOCLIEN,"ST",$P(TODTFM,".",1),1))
  1. S SDE=$O(^SC(SDTOCLIEN,"T"_SDDOW,TODTFM+1),-1)
  1. ; If never defined on a specific DOW, check continue indefintely node
  1. I 'SDE S SDE=9999999
  1. S SDTP=$G(^SC(SDTOCLIEN,"T"_SDDOW,SDE,1))
  1. Q $S(SDTP="":0,1:1)
  1. ;
  1. IDTIMESLOT(CLIEN,MAXSLOTS,CLINID) ;
  1. ; CLIEN = IEN of clinic
  1. ; MAXSLOTS = Maximum # of slots to check allowable
  1. N SDINDX,SDINDXEND,POP
  1. S POP=0
  1. S SDINDX=$P(SDSEGMENTS(CLIEN,CLINID,"EVALUATE"),U,1)-.0001
  1. S SDINDXEND=$P(SDSEGMENTS(CLIEN,CLINID,"EVALUATE"),U,2)
  1. F S SDINDX=$O(SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",SDINDX)) Q:'SDINDX!(SDINDX>=+SDINDXEND) D Q:POP
  1. .I $P(SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",SDINDX),U,2)>MAXSLOTS S POP=1
  1. Q POP
  1. ;
  1. CHKAVAILABILITY(RES,CLIEN,APPTDTNET,CLINID,MOVE2DATE) ;Check the Clinic Resource and Appt Dt for slot availability
  1. ; RES - Clinic resource of the new appointment
  1. ; CLIEN - IEN of clinic being evaluated
  1. ; APPTDTNET - Appointment date/time in external format
  1. ; CLINID - F = From clinic, T = To clinic
  1. ; MOVE2DAT - The original appt date/tm or the new appt date/tm in FM format
  1. ;
  1. N RET,TEXT,I,DATA,SLOTS,CNT,EVALSTRT,EVALSTOP,APPTSTRT,APPTEND,EAPPTDATA
  1. S SLOTS="",CNT=0
  1. S EVALSTRT=+SDSEGMENTS(CLIEN,CLINID,"EVALUATE")
  1. S EVALSTOP=+$P(SDSEGMENTS(CLIEN,CLINID,"EVALUATE"),U,2)
  1. K ^TMP("SDEC57",$J)
  1. D APPSLOTS^SDEC57(.RET,RES,APPTDTNET,APPTDTNET)
  1. S TEXT=$G(^TMP("SDEC57",$J,"APPSLOTS",1))
  1. I $P(TEXT,"^",1)=-1 D Q
  1. .S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,$P(TEXT,"^",2))
  1. I CLINID="T",TEXT="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic is not open on this date") Q
  1. ;
  1. ;DATA = fm dt ^ fm time ^ ^# of slots
  1. S I=0
  1. F S I=$O(^TMP("SDEC57",$J,"APPSLOTS",I)) Q:I="" D Q:POP
  1. .S DATA=^TMP("SDEC57",$J,"APPSLOTS",I)
  1. .S DATA=$$CTRL^XMXUTIL1(DATA)
  1. .I +$P(DATA,"^",2)<EVALSTRT Q
  1. .I +$P(DATA,"^",2)>=EVALSTOP Q
  1. .S SLOTS=$P(DATA,"^",4)
  1. .Q:SLOTS="" ; Appears APPSLOTS^SDEC57 puts a "" to represent the period after the end of clinic availability
  1. .I CLINID="F" D ; ### check order of next 2 lines
  1. ..I SLOTS'="0",SLOTS'="1",SLOTS'="*" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"appointment currently overbooked") Q
  1. ..;If orig appt slot is overbook, no B&M
  1. ..I +$P(DATA,U,2)=+$$PADFMTIME^SDESUTIL($P(FROMDTFM,".",2)) D
  1. ...I SLOTS'=0,SLOTS'="*" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"appointment currently overbooked")
  1. .I CLINID="T" D Q:POP
  1. ..I SLOTS'>0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic has no availability") Q
  1. ; Check for existing appts in clinic based on Start/End time of appt
  1. Q:POP
  1. N TIME,IEN
  1. S TIME=$$PADLENGTH^SDESUTIL(EVALSTOP,"0",4,"F")
  1. S TIME=$P(MOVE2DATE,".",1)_"."_TIME
  1. F S TIME=$O(^SDEC(409.84,"ARSRC",RES,+TIME),-1) Q:TIME'[$P(MOVE2DATE,".",1) D Q:POP
  1. .S IEN=""
  1. .F S IEN=$O(^SDEC(409.84,"ARSRC",RES,TIME,IEN)) Q:'IEN D Q:POP
  1. ..Q:IEN=APPTIEN
  1. ..S EAPPTDATA=$G(^SDEC(409.84,IEN,0))
  1. ..Q:EAPPTDATA=""
  1. ..; Skip cancelled appts
  1. ..I $P(EAPPTDATA,U,17)'=""&("C^CA^PC^PCA^"["^"_$P(EAPPTDATA,U,17)_"^") Q
  1. ..S APPTSTRT=$E($P($P(EAPPTDATA,"^",1),".",2)_"0000",1,4)
  1. ..S APPTEND=$E($P($P(EAPPTDATA,"^",2),".",2)_"0000",1,4)
  1. ..; The Appt start time > EVALUATE start time
  1. ..I APPTSTRT>EVALSTRT S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Existing scheduling conflict") Q
  1. ..; If any existing appt has a partial overlap within our EVALUATE Start/End - can't B&M
  1. ..I APPTEND>EVALSTRT,APPTEND<EVALSTOP S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Existing scheduling conflict") Q
  1. Q