SDEC13 ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
;
Q
;
AVDELDT(SDECY,SDECRESD,SDECSTART,SDECEND) ;Cancel availability in a date range
;AVDELDT(SDECY,SDECRESD,SDECSTART,SDECEND) external parameter tag is in SDEC
;SDECRESD is SDEC RESOURCE ien
;SDECSTART and SDECEND are external dates
;
N BMXIEN,SDECI,%DT,X,Y
N SDBEG,SDCL,SDEND,SDECNOD
S SDECI=0
S SDECY="^TMP(""SDEC"","_$J_")"
K ^TMP("SDEC",$J)
S ^TMP("SDEC",$J,SDECI)="I00020ERRORID^T00030ERRORTEXT"_$C(30)
S X=SDECSTART
S %DT="X" D ^%DT
I Y=-1 D ERR(0,"AVDELDT-SDEC13: Invalid Start Date") Q
S SDECSTART=$P(Y,".")
S X=SDECEND
S %DT="X" D ^%DT
I Y=-1 D ERR(0,"AVDELDT-SDEC13: Invalid End Date") Q
S SDECEND=$P(Y,".")_".2359"
I '+SDECRESD D ERR(0,"AVDELDT-SDEC13: Invalid Resource ID") Q
I $P($P($G(^SDEC(409.831,+SDECRESD,0)),U,11),";",2)'="SC(" D ERR(0,"AVDELDT-SDEC13: Resource is not a Clinic type") Q ;only add to clinics
;get resource, start, end times
S SDCL=$$GET1^DIQ(409.831,SDECRESD_",",.04,"I")
;
F S SDECSTART=$O(^SDEC(409.821,"ARSCT",SDECRESD,SDECSTART)) Q:'+SDECSTART Q:SDECSTART>SDECEND D
. S BMXIEN=0
. F S BMXIEN=$O(^SDEC(409.821,"ARSCT",SDECRESD,SDECSTART,BMXIEN)) Q:'+BMXIEN D
. . ;get resource, start, end times
. . S SDECNOD=$G(^SDEC(409.821,BMXIEN,0))
. . S SDBEG=$P(SDECNOD,U,2)
. . S SDEND=$P(SDECNOD,U,3)
. . D CALLDIK(BMXIEN)
. . ;delete AVAILABILITY from file 44
. . D DEL^SDEC12(SDCL,SDBEG,SDEND)
;
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)="-1^"_$C(30)_$C(31)
Q
ERROR ;
D ^%ZTER
I '+$G(SDECI) N SDECI S SDECI=999999
S SDECI=SDECI+1
D ERR(0,"SDEC13 Error")
Q
;
ERR(SDECERID,ERRTXT) ;Error processing
S:'+$G(SDECI) SDECI=999999
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=SDECERID_"^"_$G(ERRTXT)_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=$C(31)
Q
;
AVDEL(SDECY,SDECAVID) ;Cancel Availability - Deletes Access Block
;AVDEL(SDECY,SDECAVID) external parameter tag is in SDEC
;Deletes Access block
;SDECAVID is entry number in SDEC ACCESS BLOCK file
;Returns error code in recordset field ERRORID
;
N SDECNOD,SDECSTART,DIK,DA,SDECID,SDECI,SDECEND,SDECRSID
N SDBEG,SDCL,SDEND,SDRES
;
S SDECI=0
S SDECY="^TMP(""SDEC"","_$J_")"
K ^TMP("SDEC",$J)
S ^TMP("SDEC",$J,0)="I00020ERRORID^T00030ERRORTEXT"_$C(30)
I '+SDECAVID D ERR(70) Q
I '$D(^SDEC(409.821,SDECAVID,0)) D ERR(70) Q
;get resource, start, end times
S SDECNOD=$G(^SDEC(409.821,SDECAVID,0))
S SDRES=$P(SDECNOD,U,1)
S SDCL=$$GET1^DIQ(409.831,SDRES_",",.04,"I")
S SDBEG=$P(SDECNOD,U,2)
S SDEND=$P(SDECNOD,U,3)
;
;Delete AVAILABILITY entries
D CALLDIK(SDECAVID)
;
;rebuild AVAILABILITY in file 44
D AV44^SDEC12($P(SDBEG,".",1),SDCL,SDRES)
;
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)="-1^"_$C(30)_$C(31)
Q
;
CALLDIK(SDECAVID) ;
;Delete AVAILABILITY entries
;
S DIK="^SDEC(409.821,"
S DA=SDECAVID
D ^DIK
;
Q
;
APTINBLK(SDECAVID) ;
;
;NOTE: This Subroutine Not called in current version. Keep code for later use.
;
;N SDECS,SDECID,SDECHIT,SDECNOD,SDECE,SDECSTART,SDECEND,SDECRSID
;S SDECNOD=^SDEC(409.821,SDECAVID,0)
;S SDECSTART=$P(SDECNOD,U,3)
;S SDECEND=$P(SDECNOD,U,4)
;S SDECRSID=$P(SDECNOD,U,1)
;I '$D(^SDECDAPRS("ARSRC",SDECRSID)) Q 0
;;If any appointments start at the AV block start time:
;I $D(^SDECDAPRS("ARSRC",SDECRSID,SDECSTART)) Q 1
;;Find the first appt time SDECS on the same day as the av block
;S SDECS=$O(^SDECDAPRS("ARSRC",SDECRSID,$P(SDECSTART,".")))
;I SDECS>SDECEND Q 0
;;For all the appts that day with start times less
;;than the av block's end time, find any whose end time is
;;greater than the av block's start time
;S SDECHIT=0
;S SDECS=SDECS-.0001
;F S SDECS=$O(^SDECDAPRS("ARSRC",SDECRSID,SDECS)) Q:'+SDECS Q:SDECS'<SDECEND D Q:SDECHIT
;. S SDECID=0 F S SDECID=$O(^SDECDAPRS("ARSRC",SDECRSID,SDECS,SDECID)) Q:'+SDECID D Q:SDECHIT
;. . Q:'$D(^SDECDAPT(SDECID,0))
;. . S SDECNOD=^SDECDAPT(SDECID,0)
;. . S SDECE=$P(SDECNOD,U,2)
;. . I SDECE>SDECSTART S SDECHIT=1 Q
;;
;I SDECHIT Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC13 4154 printed Nov 22, 2024@18:00:07 Page 2
SDEC13 ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
+1 ;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
+2 ;
+3 QUIT
+4 ;
AVDELDT(SDECY,SDECRESD,SDECSTART,SDECEND) ;Cancel availability in a date range
+1 ;AVDELDT(SDECY,SDECRESD,SDECSTART,SDECEND) external parameter tag is in SDEC
+2 ;SDECRESD is SDEC RESOURCE ien
+3 ;SDECSTART and SDECEND are external dates
+4 ;
+5 NEW BMXIEN,SDECI,%DT,X,Y
+6 NEW SDBEG,SDCL,SDEND,SDECNOD
+7 SET SDECI=0
+8 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+9 KILL ^TMP("SDEC",$JOB)
+10 SET ^TMP("SDEC",$JOB,SDECI)="I00020ERRORID^T00030ERRORTEXT"_$CHAR(30)
+11 SET X=SDECSTART
+12 SET %DT="X"
DO ^%DT
+13 IF Y=-1
DO ERR(0,"AVDELDT-SDEC13: Invalid Start Date")
QUIT
+14 SET SDECSTART=$PIECE(Y,".")
+15 SET X=SDECEND
+16 SET %DT="X"
DO ^%DT
+17 IF Y=-1
DO ERR(0,"AVDELDT-SDEC13: Invalid End Date")
QUIT
+18 SET SDECEND=$PIECE(Y,".")_".2359"
+19 IF '+SDECRESD
DO ERR(0,"AVDELDT-SDEC13: Invalid Resource ID")
QUIT
+20 ;only add to clinics
IF $PIECE($PIECE($GET(^SDEC(409.831,+SDECRESD,0)),U,11),";",2)'="SC("
DO ERR(0,"AVDELDT-SDEC13: Resource is not a Clinic type")
QUIT
+21 ;get resource, start, end times
+22 SET SDCL=$$GET1^DIQ(409.831,SDECRESD_",",.04,"I")
+23 ;
+24 FOR
SET SDECSTART=$ORDER(^SDEC(409.821,"ARSCT",SDECRESD,SDECSTART))
if '+SDECSTART
QUIT
if SDECSTART>SDECEND
QUIT
Begin DoDot:1
+25 SET BMXIEN=0
+26 FOR
SET BMXIEN=$ORDER(^SDEC(409.821,"ARSCT",SDECRESD,SDECSTART,BMXIEN))
if '+BMXIEN
QUIT
Begin DoDot:2
+27 ;get resource, start, end times
+28 SET SDECNOD=$GET(^SDEC(409.821,BMXIEN,0))
+29 SET SDBEG=$PIECE(SDECNOD,U,2)
+30 SET SDEND=$PIECE(SDECNOD,U,3)
+31 DO CALLDIK(BMXIEN)
+32 ;delete AVAILABILITY from file 44
+33 DO DEL^SDEC12(SDCL,SDBEG,SDEND)
End DoDot:2
End DoDot:1
+34 ;
+35 SET SDECI=SDECI+1
+36 SET ^TMP("SDEC",$JOB,SDECI)="-1^"_$CHAR(30)_$CHAR(31)
+37 QUIT
ERROR ;
+1 DO ^%ZTER
+2 IF '+$GET(SDECI)
NEW SDECI
SET SDECI=999999
+3 SET SDECI=SDECI+1
+4 DO ERR(0,"SDEC13 Error")
+5 QUIT
+6 ;
ERR(SDECERID,ERRTXT) ;Error processing
+1 if '+$GET(SDECI)
SET SDECI=999999
+2 SET SDECI=SDECI+1
+3 SET ^TMP("SDEC",$JOB,SDECI)=SDECERID_"^"_$GET(ERRTXT)_$CHAR(30)
+4 SET SDECI=SDECI+1
+5 SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(31)
+6 QUIT
+7 ;
AVDEL(SDECY,SDECAVID) ;Cancel Availability - Deletes Access Block
+1 ;AVDEL(SDECY,SDECAVID) external parameter tag is in SDEC
+2 ;Deletes Access block
+3 ;SDECAVID is entry number in SDEC ACCESS BLOCK file
+4 ;Returns error code in recordset field ERRORID
+5 ;
+6 NEW SDECNOD,SDECSTART,DIK,DA,SDECID,SDECI,SDECEND,SDECRSID
+7 NEW SDBEG,SDCL,SDEND,SDRES
+8 ;
+9 SET SDECI=0
+10 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+11 KILL ^TMP("SDEC",$JOB)
+12 SET ^TMP("SDEC",$JOB,0)="I00020ERRORID^T00030ERRORTEXT"_$CHAR(30)
+13 IF '+SDECAVID
DO ERR(70)
QUIT
+14 IF '$DATA(^SDEC(409.821,SDECAVID,0))
DO ERR(70)
QUIT
+15 ;get resource, start, end times
+16 SET SDECNOD=$GET(^SDEC(409.821,SDECAVID,0))
+17 SET SDRES=$PIECE(SDECNOD,U,1)
+18 SET SDCL=$$GET1^DIQ(409.831,SDRES_",",.04,"I")
+19 SET SDBEG=$PIECE(SDECNOD,U,2)
+20 SET SDEND=$PIECE(SDECNOD,U,3)
+21 ;
+22 ;Delete AVAILABILITY entries
+23 DO CALLDIK(SDECAVID)
+24 ;
+25 ;rebuild AVAILABILITY in file 44
+26 DO AV44^SDEC12($PIECE(SDBEG,".",1),SDCL,SDRES)
+27 ;
+28 SET SDECI=SDECI+1
+29 SET ^TMP("SDEC",$JOB,SDECI)="-1^"_$CHAR(30)_$CHAR(31)
+30 QUIT
+31 ;
CALLDIK(SDECAVID) ;
+1 ;Delete AVAILABILITY entries
+2 ;
+3 SET DIK="^SDEC(409.821,"
+4 SET DA=SDECAVID
+5 DO ^DIK
+6 ;
+7 QUIT
+8 ;
APTINBLK(SDECAVID) ;
+1 ;
+2 ;NOTE: This Subroutine Not called in current version. Keep code for later use.
+3 ;
+4 ;N SDECS,SDECID,SDECHIT,SDECNOD,SDECE,SDECSTART,SDECEND,SDECRSID
+5 ;S SDECNOD=^SDEC(409.821,SDECAVID,0)
+6 ;S SDECSTART=$P(SDECNOD,U,3)
+7 ;S SDECEND=$P(SDECNOD,U,4)
+8 ;S SDECRSID=$P(SDECNOD,U,1)
+9 ;I '$D(^SDECDAPRS("ARSRC",SDECRSID)) Q 0
+10 ;;If any appointments start at the AV block start time:
+11 ;I $D(^SDECDAPRS("ARSRC",SDECRSID,SDECSTART)) Q 1
+12 ;;Find the first appt time SDECS on the same day as the av block
+13 ;S SDECS=$O(^SDECDAPRS("ARSRC",SDECRSID,$P(SDECSTART,".")))
+14 ;I SDECS>SDECEND Q 0
+15 ;;For all the appts that day with start times less
+16 ;;than the av block's end time, find any whose end time is
+17 ;;greater than the av block's start time
+18 ;S SDECHIT=0
+19 ;S SDECS=SDECS-.0001
+20 ;F S SDECS=$O(^SDECDAPRS("ARSRC",SDECRSID,SDECS)) Q:'+SDECS Q:SDECS'<SDECEND D Q:SDECHIT
+21 ;. S SDECID=0 F S SDECID=$O(^SDECDAPRS("ARSRC",SDECRSID,SDECS,SDECID)) Q:'+SDECID D Q:SDECHIT
+22 ;. . Q:'$D(^SDECDAPT(SDECID,0))
+23 ;. . S SDECNOD=^SDECDAPT(SDECID,0)
+24 ;. . S SDECE=$P(SDECNOD,U,2)
+25 ;. . I SDECE>SDECSTART S SDECHIT=1 Q
+26 ;;
+27 ;I SDECHIT Q 1
+28 QUIT 0
