SDEC12 ;ALB/SAT,WTC - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
;;5.3;Scheduling;**627,694**;Aug 13, 1993;Build 61
;
Q
;
AVADD(SDECY,SDECSTART,SDECEND,SDECTYPID,SDECRES,SDECSLOTS,SDECNOTE) ;Create entry in SDEC ACCESS BLOCK
;AVADD(SDECY,SDECSTART,SDECEND,SDECTYPID,SDECRES,SDECSLOTS,SDECNOTE) external parameter tag is in SDEC
;INPUT:
; SDECSTART - (required) SDEC ACCESS BLOCK start date/time
; SDECEND - (required) SDEC ACCESS BLOCK end date/time
; SDECTYPID - (required) ACCESS TYPE ien - pointer to the SDEC ACCESS TYPE file
; SDECRES - (required) Resource Name from the NAME field of the
; SDEC RESOURCE file
; SDECSLOTS - (required) Value added to the SLOTS field of the
; SDEC ACCESS BLOCK file (must be 0-99)
; SDECNOTE - (optional) Represents a note; will be converted to a WP field
;
;RETURN:
; Recordset having fields
; AvailabilityID and ErrorNumber
;
;
N SDAB,SDECERR,SDECIEN,SDECDEP,SDECI,SDECAVID,SDECI,SDECERR,SDECFDA,SDECMSG,SDECRESD,SDECTMP
N SDI,SDNOD,%DT,X,Y
K ^TMP("SDEC",$J)
S SDECERR=0
S SDECI=0
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,0)="I00020AVAILABILITYID^I00020ERRORID"_$C(30)
;Check input data for errors
;
; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
;
;S:SDECSTART["@0000" SDECSTART=$P(SDECSTART,"@")
;S:SDECEND["@0000" SDECEND=$P(SDECEND,"@")
;S %DT="RXT",X=SDECSTART D ^%DT S SDECSTART=Y
;I SDECSTART=-1 D ERR(70) Q
S SDECSTART=$$NETTOFM^SDECDATE(SDECSTART,"Y") I SDECSTART=-1 D ERR(70) Q ;
;S %DT="RXT",X=SDECEND D ^%DT S SDECEND=Y
;I SDECEND=-1 D ERR(70) Q
;I $L(SDECEND,".")=1 D ERR(70) Q
S SDECEND=$$NETTOFM^SDECDATE(SDECEND,"Y") I SDECEND=-1 D ERR(70) Q ;
I SDECSTART>SDECEND S SDECTMP=SDECEND,SDECEND=SDECSTART,SDECSTART=SDECTMP
I $P(SDECSTART,".",1)'=$P(SDECEND,".",1) D ERR(70) Q
;Validate Access Type
I '+SDECTYPID D ERR(70) Q
I '$D(^SDEC(409.823,+SDECTYPID,0)) D ERR(70) Q
;Validate Resource
I '$D(^SDEC(409.831,"B",SDECRES)) S SDECERR=70 D ERR(SDECERR) Q
S SDECRESD=$O(^SDEC(409.831,"B",SDECRES,0)) I '+SDECRESD S SDECERR=70 D ERR(SDECERR) Q
S SDNOD=$G(^SDEC(409.831,SDECRESD,0))
I $P($P(SDNOD,U,11),";",2)'="SC(" D ERR(70) Q ;only add to clinics
;Validate SDECSLOTS
S SDECSLOTS=$G(SDECSLOTS,0)
;get current slots for the day
S SDAB="^TMP("_$J_",""SDEC"",""BLKS"")"
K @SDAB
D GETSLOTS^SDEC04(SDAB,SDECRESD,$P(SDECSTART,".",1),$P(SDECEND,".",1)_".2359")
S SDI=$P($G(@SDAB@("CNT")),U,1)+1
S @SDAB@(SDI)=U_SDECSTART_U_SDECEND_U_SDECSLOTS_U_SDECTYPID
;
;update AVAILABILITY in file 44 for clinic type resource
D AV44($P(SDECSTART,".",1),$P(SDNOD,U,4),SDECRESD)
;
;Return Recordset
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=SDECAVID_"^-1"_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=$C(31)
Q
;
AV44(SDAY,SDCL,SDRES) ;update AVAILABILITY in file 44
N SDAB,SDAPL,SDI,SDJ,SDNOD
N CNT,LAST,H1,H2,M1,M2
S SDAPL=$$GET1^DIQ(44,SDCL_",",1912,"I")
;delete all slots for the day in file 44
D DEL(SDCL,SDAY_".0001",SDAY_".2359")
;add all blocks for the day to file 44
S CNT=0
S SDI=0 F S SDI=$O(@SDAB@(SDI)) Q:SDI'>0 D
.S SDNOD=@SDAB@(SDI)
.Q:'$P(SDNOD,U,4)
.S H1=$E($P($P(SDNOD,U,2),".",2),1,2) S:H1?1N H1=H1_"0"
.S M1=$E($P($P(SDNOD,U,2),".",2),3,4) S:M1?1N M1=M1_"0" S:M1="" M1="00"
.S H2=$E($P($P(SDNOD,U,3),".",2),1,2) S:H2?1N H2=H2_"0"
.S M2=$E($P($P(SDNOD,U,3),".",2),3,4) S:M2?1N M2=M2_"0" S:M2="" M2="00"
.D AVA(.CNT,SDCL,SDAY,H1_M1,H2_M2,$P(SDNOD,U,4),SDAPL)
;update zero node for day
I +CNT S ^SC(SDCL,"T",SDAY,2,0)="^44.004A^"_CNT_"^"_CNT
;update zero node for "T"
S (CNT,LAST,SDI)=0 F S SDI=$O(^SC(SDCL,"T",SDI)) Q:SDI'>0 D
.S LAST=SDI,CNT=CNT+1
S ^SC(SDCL,"T",0)="^44.002DA^"_LAST_"^"_CNT
D CA(SDCL,SDAY)
Q
CA(SDCL,SDAY) ;set current availability in PATTERN if does not already exist
N D,D0,DA,DH,DO,DOW,SDREACT,SI,SL,STARTDAY,%DT,X,Y N CTR,OK
S DA=SDCL
S D0=SDAY
S SL=^SC(DA,"SL")
S D=$P(SL,U,6),SI=$S(D:D,1:4)
S DH=SL*SI\60
S STARTDAY=$$GET1^DIQ(44,DA_",",1914) S:STARTDAY="" STARTDAY=8
;build pattern from AVAILABILITY; from SDB0
F X=0:0 S X=$O(^SC(DA,"T",D0,2,X)) Q:X'>0 S Y=^(X,0) 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)
S (DH,DO,X)=""
;I $D(HSI) I HSI=1!(HSI=2) D CKSI1^SDB0
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))'>0 Q
K Y
S DH=X,OK=0,CTR=0
S D=D0,X=D0,DO=$$FMADD^XLFDT(X,1)
S X=D,Y="" D DOW^SDM0 S DOW=Y
S ^SC(DA,"ST",X,9)=D,SDREACT=1 S:'$D(^SC(DA,"ST",0)) ^(0)="^44.005DA^^" D B1^SDB1
Q
AVA(CNT,SDCL,SDAY,T1,T2,SDSLOTS,SDAPL) ;add block to AVAILABILITY
N ADF,FM,H1,M1,SDTIME
Q:'SDSLOTS
S ADF=0
I '$D(^SC(SDCL,"T",SDAY,0)) S ^SC(SDCL,"T",SDAY,0)=SDAY S ADF=1
S SDTIME=T1
F Q:(SDAY_"."_SDTIME)>(SDAY_"."_T2) D
.S CNT=CNT+1 S ^SC(SDCL,"T",SDAY,2,CNT,0)=SDTIME_"^"_SDSLOTS
.S FM=SDAY_"."_SDTIME S FM=$$FMADD^XLFDT(FM,,,SDAPL)
.S H1=$E($P(FM,".",2),1,2) S:H1?1N H1=H1_"0"
.S M1=$E($P(FM,".",2),3,4) S:M1?1N M1=M1_"0" S:M1="" M1="00"
.S SDTIME=H1_M1
Q
;
DEL(SDCL,SDBEG,SDEND) ;delete AVAILABILITY from file 44
N AV,D1,D2,DIK,H1,H2,M1,M2,SDAY,SDI,SDNOD
S SDAY=$P(SDBEG,".",1)
Q:'$D(^SC(SDCL,"T",SDAY))
S H1=$E($P(SDBEG,".",2),1,2) S:H1?1N H1=H1_"0"
S M1=$E($P(SDBEG,".",2),3,4) S:M1?1N M1=M1_"0" S:M1="" M1="00"
S H2=$E($P(SDEND,".",2),1,2) S:H2?1N H2=H2_"0"
S M2=$E($P(SDEND,".",2),3,4) S:M2?1N M2=M2_"0" S:M2="" M2="00"
;array of existing blocks
S SDI=0 F S SDI=$O(^SC(SDCL,"T",SDAY,2,SDI)) Q:SDI'>0 D
.S AV($P($G(^SC(SDCL,"T",SDAY,2,SDI,0)),U,1))=SDI
Q:'$D(AV)
S D1=$G(AV(H1_M1),1),D2=$G(AV(H2_M2),999)
S SDI=D1-1 F S SDI=$O(^SC(SDCL,"T",SDAY,2,SDI)) Q:SDI'>0 Q:SDI>D2 D
.S DIK="^SC("_SDCL_",""T"","_SDAY_",2,"
.S DA=SDI
.D ^DIK
Q
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
ERR(ERRNO) ;Error processing
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)="0^"_ERRNO_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=$C(31)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC12 6124 printed Dec 13, 2024@02:50:05 Page 2
SDEC12 ;ALB/SAT,WTC - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
+1 ;;5.3;Scheduling;**627,694**;Aug 13, 1993;Build 61
+2 ;
+3 QUIT
+4 ;
AVADD(SDECY,SDECSTART,SDECEND,SDECTYPID,SDECRES,SDECSLOTS,SDECNOTE) ;Create entry in SDEC ACCESS BLOCK
+1 ;AVADD(SDECY,SDECSTART,SDECEND,SDECTYPID,SDECRES,SDECSLOTS,SDECNOTE) external parameter tag is in SDEC
+2 ;INPUT:
+3 ; SDECSTART - (required) SDEC ACCESS BLOCK start date/time
+4 ; SDECEND - (required) SDEC ACCESS BLOCK end date/time
+5 ; SDECTYPID - (required) ACCESS TYPE ien - pointer to the SDEC ACCESS TYPE file
+6 ; SDECRES - (required) Resource Name from the NAME field of the
+7 ; SDEC RESOURCE file
+8 ; SDECSLOTS - (required) Value added to the SLOTS field of the
+9 ; SDEC ACCESS BLOCK file (must be 0-99)
+10 ; SDECNOTE - (optional) Represents a note; will be converted to a WP field
+11 ;
+12 ;RETURN:
+13 ; Recordset having fields
+14 ; AvailabilityID and ErrorNumber
+15 ;
+16 ;
+17 NEW SDAB,SDECERR,SDECIEN,SDECDEP,SDECI,SDECAVID,SDECI,SDECERR,SDECFDA,SDECMSG,SDECRESD,SDECTMP
+18 NEW SDI,SDNOD,%DT,X,Y
+19 KILL ^TMP("SDEC",$JOB)
+20 SET SDECERR=0
+21 SET SDECI=0
+22 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+23 SET ^TMP("SDEC",$JOB,0)="I00020AVAILABILITYID^I00020ERRORID"_$CHAR(30)
+24 ;Check input data for errors
+25 ;
+26 ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
+27 ;
+28 ;S:SDECSTART["@0000" SDECSTART=$P(SDECSTART,"@")
+29 ;S:SDECEND["@0000" SDECEND=$P(SDECEND,"@")
+30 ;S %DT="RXT",X=SDECSTART D ^%DT S SDECSTART=Y
+31 ;I SDECSTART=-1 D ERR(70) Q
+32 ;
SET SDECSTART=$$NETTOFM^SDECDATE(SDECSTART,"Y")
IF SDECSTART=-1
DO ERR(70)
QUIT
+33 ;S %DT="RXT",X=SDECEND D ^%DT S SDECEND=Y
+34 ;I SDECEND=-1 D ERR(70) Q
+35 ;I $L(SDECEND,".")=1 D ERR(70) Q
+36 ;
SET SDECEND=$$NETTOFM^SDECDATE(SDECEND,"Y")
IF SDECEND=-1
DO ERR(70)
QUIT
+37 IF SDECSTART>SDECEND
SET SDECTMP=SDECEND
SET SDECEND=SDECSTART
SET SDECSTART=SDECTMP
+38 IF $PIECE(SDECSTART,".",1)'=$PIECE(SDECEND,".",1)
DO ERR(70)
QUIT
+39 ;Validate Access Type
+40 IF '+SDECTYPID
DO ERR(70)
QUIT
+41 IF '$DATA(^SDEC(409.823,+SDECTYPID,0))
DO ERR(70)
QUIT
+42 ;Validate Resource
+43 IF '$DATA(^SDEC(409.831,"B",SDECRES))
SET SDECERR=70
DO ERR(SDECERR)
QUIT
+44 SET SDECRESD=$ORDER(^SDEC(409.831,"B",SDECRES,0))
IF '+SDECRESD
SET SDECERR=70
DO ERR(SDECERR)
QUIT
+45 SET SDNOD=$GET(^SDEC(409.831,SDECRESD,0))
+46 ;only add to clinics
IF $PIECE($PIECE(SDNOD,U,11),";",2)'="SC("
DO ERR(70)
QUIT
+47 ;Validate SDECSLOTS
+48 SET SDECSLOTS=$GET(SDECSLOTS,0)
+49 ;get current slots for the day
+50 SET SDAB="^TMP("_$JOB_",""SDEC"",""BLKS"")"
+51 KILL @SDAB
+52 DO GETSLOTS^SDEC04(SDAB,SDECRESD,$PIECE(SDECSTART,".",1),$PIECE(SDECEND,".",1)_".2359")
+53 SET SDI=$PIECE($GET(@SDAB@("CNT")),U,1)+1
+54 SET @SDAB@(SDI)=U_SDECSTART_U_SDECEND_U_SDECSLOTS_U_SDECTYPID
+55 ;
+56 ;update AVAILABILITY in file 44 for clinic type resource
+57 DO AV44($PIECE(SDECSTART,".",1),$PIECE(SDNOD,U,4),SDECRESD)
+58 ;
+59 ;Return Recordset
+60 SET SDECI=SDECI+1
+61 SET ^TMP("SDEC",$JOB,SDECI)=SDECAVID_"^-1"_$CHAR(30)
+62 SET SDECI=SDECI+1
+63 SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(31)
+64 QUIT
+65 ;
AV44(SDAY,SDCL,SDRES) ;update AVAILABILITY in file 44
+1 NEW SDAB,SDAPL,SDI,SDJ,SDNOD
+2 NEW CNT,LAST,H1,H2,M1,M2
+3 SET SDAPL=$$GET1^DIQ(44,SDCL_",",1912,"I")
+4 ;delete all slots for the day in file 44
+5 DO DEL(SDCL,SDAY_".0001",SDAY_".2359")
+6 ;add all blocks for the day to file 44
+7 SET CNT=0
+8 SET SDI=0
FOR
SET SDI=$ORDER(@SDAB@(SDI))
if SDI'>0
QUIT
Begin DoDot:1
+9 SET SDNOD=@SDAB@(SDI)
+10 if '$PIECE(SDNOD,U,4)
QUIT
+11 SET H1=$EXTRACT($PIECE($PIECE(SDNOD,U,2),".",2),1,2)
if H1?1N
SET H1=H1_"0"
+12 SET M1=$EXTRACT($PIECE($PIECE(SDNOD,U,2),".",2),3,4)
if M1?1N
SET M1=M1_"0"
if M1=""
SET M1="00"
+13 SET H2=$EXTRACT($PIECE($PIECE(SDNOD,U,3),".",2),1,2)
if H2?1N
SET H2=H2_"0"
+14 SET M2=$EXTRACT($PIECE($PIECE(SDNOD,U,3),".",2),3,4)
if M2?1N
SET M2=M2_"0"
if M2=""
SET M2="00"
+15 DO AVA(.CNT,SDCL,SDAY,H1_M1,H2_M2,$PIECE(SDNOD,U,4),SDAPL)
End DoDot:1
+16 ;update zero node for day
+17 IF +CNT
SET ^SC(SDCL,"T",SDAY,2,0)="^44.004A^"_CNT_"^"_CNT
+18 ;update zero node for "T"
+19 SET (CNT,LAST,SDI)=0
FOR
SET SDI=$ORDER(^SC(SDCL,"T",SDI))
if SDI'>0
QUIT
Begin DoDot:1
+20 SET LAST=SDI
SET CNT=CNT+1
End DoDot:1
+21 SET ^SC(SDCL,"T",0)="^44.002DA^"_LAST_"^"_CNT
+22 DO CA(SDCL,SDAY)
+23 QUIT
CA(SDCL,SDAY) ;set current availability in PATTERN if does not already exist
+1 NEW D,D0,DA,DH,DO,DOW,SDREACT,SI,SL,STARTDAY,%DT,X,Y
NEW CTR,OK
+2 SET DA=SDCL
+3 SET D0=SDAY
+4 SET SL=^SC(DA,"SL")
+5 SET D=$PIECE(SL,U,6)
SET SI=$SELECT(D:D,1:4)
+6 SET DH=SL*SI\60
+7 SET STARTDAY=$$GET1^DIQ(44,DA_",",1914)
if STARTDAY=""
SET STARTDAY=8
+8 ;build pattern from AVAILABILITY; from SDB0
+9 FOR X=0:0
SET X=$ORDER(^SC(DA,"T",D0,2,X))
if X'>0
QUIT
SET Y=^(X,0)
FOR D=1:1:DH
SET Y(Y#100*SI\60+(Y\100*SI)-(STARTDAY*SI)+D)=$SELECT($PIECE(Y,U,2):$EXTRACT("123456789jklmnopqrstuvwxyz",$PIECE(Y,U,2)),1:0)
+10 SET (DH,DO,X)=""
+11 ;I $D(HSI) I HSI=1!(HSI=2) D CKSI1^SDB0
+12 FOR Y=1:1
SET DH=$DATA(Y(Y))
SET X=X_$SELECT('DH&DO:"]",'DO&DH:"[",Y#SI=1:"|",1:" ")_$SELECT(DH:Y(Y),1:" ")
SET DO=DH
IF 'DH
IF $ORDER(Y(Y))'>0
QUIT
+13 KILL Y
+14 SET DH=X
SET OK=0
SET CTR=0
+15 SET D=D0
SET X=D0
SET DO=$$FMADD^XLFDT(X,1)
+16 SET X=D
SET Y=""
DO DOW^SDM0
SET DOW=Y
+17 SET ^SC(DA,"ST",X,9)=D
SET SDREACT=1
if '$DATA(^SC(DA,"ST",0))
SET ^(0)="^44.005DA^^"
DO B1^SDB1
+18 QUIT
AVA(CNT,SDCL,SDAY,T1,T2,SDSLOTS,SDAPL) ;add block to AVAILABILITY
+1 NEW ADF,FM,H1,M1,SDTIME
+2 if 'SDSLOTS
QUIT
+3 SET ADF=0
+4 IF '$DATA(^SC(SDCL,"T",SDAY,0))
SET ^SC(SDCL,"T",SDAY,0)=SDAY
SET ADF=1
+5 SET SDTIME=T1
+6 FOR
if (SDAY_"."_SDTIME)>(SDAY_"."_T2)
QUIT
Begin DoDot:1
+7 SET CNT=CNT+1
SET ^SC(SDCL,"T",SDAY,2,CNT,0)=SDTIME_"^"_SDSLOTS
+8 SET FM=SDAY_"."_SDTIME
SET FM=$$FMADD^XLFDT(FM,,,SDAPL)
+9 SET H1=$EXTRACT($PIECE(FM,".",2),1,2)
if H1?1N
SET H1=H1_"0"
+10 SET M1=$EXTRACT($PIECE(FM,".",2),3,4)
if M1?1N
SET M1=M1_"0"
if M1=""
SET M1="00"
+11 SET SDTIME=H1_M1
End DoDot:1
+12 QUIT
+13 ;
DEL(SDCL,SDBEG,SDEND) ;delete AVAILABILITY from file 44
+1 NEW AV,D1,D2,DIK,H1,H2,M1,M2,SDAY,SDI,SDNOD
+2 SET SDAY=$PIECE(SDBEG,".",1)
+3 if '$DATA(^SC(SDCL,"T",SDAY))
QUIT
+4 SET H1=$EXTRACT($PIECE(SDBEG,".",2),1,2)
if H1?1N
SET H1=H1_"0"
+5 SET M1=$EXTRACT($PIECE(SDBEG,".",2),3,4)
if M1?1N
SET M1=M1_"0"
if M1=""
SET M1="00"
+6 SET H2=$EXTRACT($PIECE(SDEND,".",2),1,2)
if H2?1N
SET H2=H2_"0"
+7 SET M2=$EXTRACT($PIECE(SDEND,".",2),3,4)
if M2?1N
SET M2=M2_"0"
if M2=""
SET M2="00"
+8 ;array of existing blocks
+9 SET SDI=0
FOR
SET SDI=$ORDER(^SC(SDCL,"T",SDAY,2,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+10 SET AV($PIECE($GET(^SC(SDCL,"T",SDAY,2,SDI,0)),U,1))=SDI
End DoDot:1
+11 if '$DATA(AV)
QUIT
+12 SET D1=$GET(AV(H1_M1),1)
SET D2=$GET(AV(H2_M2),999)
+13 SET SDI=D1-1
FOR
SET SDI=$ORDER(^SC(SDCL,"T",SDAY,2,SDI))
if SDI'>0
QUIT
if SDI>D2
QUIT
Begin DoDot:1
+14 SET DIK="^SC("_SDCL_",""T"","_SDAY_",2,"
+15 SET DA=SDI
+16 DO ^DIK
End DoDot:1
+17 QUIT
+18 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
ERR(ERRNO) ;Error processing
+1 SET SDECI=SDECI+1
+2 SET ^TMP("SDEC",$JOB,SDECI)="0^"_ERRNO_$CHAR(30)
+3 SET SDECI=SDECI+1
+4 SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(31)
+5 QUIT
