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