SDEC07C ;ALB/WTC/ZEB,KML,LAB - VISTA SCHEDULING RPCS ;JAN 12,2023
;;5.3;Scheduling;**686,694,816,820,837**;Aug 13, 1993;Build 4
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to $$LOCK1^ORX2 is supported by IA #867
; Reference to UNKL1^ORX2 is supported by IA #867
Q
;
ADDEVT(DFN,SDECSTART,SDECSC,SDCLA) ;EP
;Called by SDEC ADD APPOINTMENT protocol
;SDECSC=IEN of clinic in ^SC
;SDCLA=IEN for ^SC(SDECSC,"S",SDECSTART,1,SDCLA). Use to get Length & Note
;
N SDECNOD,SDECLEN,SDECAPPTID,SDECNODP,SDECWKIN,SDECRES
Q:+$G(SDECNOEV)
I $D(^SDEC(409.831,"ALOC",SDECSC)) S SDECRES=$O(^SDEC(409.831,"ALOC",SDECSC,0))
Q:'+$G(SDECRES)
S SDECNOD=$G(^SC(SDECSC,"S",SDECSTART,1,SDCLA,0))
Q:SDECNOD=""
S SDECNODP=$G(^DPT(DFN,"S",SDECSTART,0))
S SDECWKIN=""
S:$P(SDECNODP,U,7)=4 SDECWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
S SDECLEN=$P(SDECNOD,U,2)
Q:'+SDECLEN
S SDECEND=$$FMADD^XLFDT(SDECSTART,0,0,SDECLEN,0)
S SDECAPPTID=$$SDECADD^SDEC07(SDECSTART,SDECEND,DFN,SDECRES,SDECWKIN,,,,,SDECSC,,,,,,1,+SDECLEN) ;alb/sat 665 add SDECLEN
Q:'+SDECAPPTID
S SDECNOTE=$P(SDECNOD,U,4)
I SDECNOTE]"" D SDECWP^SDEC07(SDECAPPTID,SDECNOTE)
D ADDEVT3(SDECRES)
Q
;
ADDEVT3(SDECRES) ;
;Call RaiseEvent to notify GUI clients
Q
;
;moved AVUPDT, DOW and DAY from SDEC07 because of XINDEX error for size pwc / SD*5.3*694
;
AVUPDT(SDCL,SDECSTART,SDECLEN) ;Update Clinic availability
;SEE SDM1
N %,ABORT,SDNOT,Y,DFN,SDVAL
N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I,SDECINC,SDPLUS
S Y=SDCL ;,DFN=DFN ;renamed SDECPATID to DFN
S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SC=Y,SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y
;Determine maximum days for scheduling
S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
S SDDATE=SDECSTART
S SDSDATE=SDDATE,SDDATE=SDDATE\1
1 ;
S CCXN=0 K MXOK,COV,SDPROT Q:$G(DFN)<0 S SC=+SC
S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
S X2=SDEDT D C^%DTC S SDEDT=X
S Y=SDECSTART
EN1 S (X,SD)=Y,SM=0 D DOW
S I '$D(^SC(SC,"ST",$P(SD,"."),1)) S SS=+$O(^SC(+SC,"T"_Y,SD)) Q:SS'>0 Q:^(SS,1)="" S ^SC(+SC,"ST",$P(SD,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(SD,".")
S S=SDECLEN
;Check if SDECLEN evenly divisible by appointment length
S SDVAL=$P(SL,U)
I SDECLEN<SDVAL S SDECLEN=SDVAL
I SDECLEN#SDVAL'=0 D
. S SDECINC=SDECLEN\SDVAL
. S SDECINC=SDECINC+1
. S SDECLEN=SDVAL*SDECINC
S SL=S_U_$P(SL,U,2,99)
SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
I SM<7 S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7
;
SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
S SDNOT=1
S ABORT=0
F I=ST+ST:SDDIF:SS-SDDIF D Q:ABORT
. S ST=$E(S,I+1) S:ST="" ST=" "
. S Y=$E(STR,$F(STR,ST)-2)
. I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
. I Y="" S ABORT=1 Q
. S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) S:ST="" ST=" " S S=$E(S,1,I)_Y_ST
S ^SC(SC,"ST",$P(SD,"."),1)=S
L -^SC(SC,"ST",$P(SD,"."),1)
Q
;
DOW N SDTMP S SDTMP=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(SDTMP#4)+$E("144025036146",Y)
F SDTMP=SDTMP:-1:281 S Y=SDTMP#4=1+1+Y
S Y=$E(X,6,7)+Y#7
Q
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
Q
ORDERLOCKCHECK(REQUESTYPE,APPTREQIEN,SDECI,DFN) ;
; sd*5.3*816 if RTC order cannot be locked then do not create appointment
; send back error message to client
;INPUT -
;REQUESTYPE - TYPE OF APPT REQUEST (e.g., APPT, RTC, VETERAN)
;APPTREQIEN - IEN of 409.85
;SDECI - Line counter for error array - passed in by reference
;DFN - ien of PATIENT file (#2)
; return ERROR = 0 or 1
N ORDERID,ERROR,USER,LOCKFLG
S LOCKFLG=0
S ORDERID=$G(ORDERID)
S ERROR=0
I REQUESTYPE="RTC" D
. S ORDERID=$$GET1^DIQ(409.85,APPTREQIEN,46,"I")
. Q:'+ORDERID
. I $D(^XTMP("ORLK-"_ORDERID)) D
. . S LOCKFLG=1
. . S USER=$$GET1^DIQ(200,$P($G(^XTMP("ORLK-"_ORDERID,1)),"^"),.01)
. . D ERR^SDEC07(SDECI+1,"RTC Order is being edited by "_USER_". Please try again later.",DFN,1) S ERROR=1
. I LOCKFLG'=1 D
. . S LOCKFLG=$$LOCK1^ORX2(ORDERID)
. . I +LOCKFLG D
. . . D UNLK1^ORX2(ORDERID)
. . I '(+LOCKFLG) D
. . . D ERR^SDEC07(SDECI+1,"RTC Order is locked by another user. Please try again later.",DFN,1) S ERROR=1
. . . S ERROR=1
Q ERROR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC07C 4872 printed Apr 09, 2024@21:41:54 Page 2
SDEC07C ;ALB/WTC/ZEB,KML,LAB - VISTA SCHEDULING RPCS ;JAN 12,2023
+1 ;;5.3;Scheduling;**686,694,816,820,837**;Aug 13, 1993;Build 4
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to $$LOCK1^ORX2 is supported by IA #867
+5 ; Reference to UNKL1^ORX2 is supported by IA #867
+6 QUIT
+7 ;
ADDEVT(DFN,SDECSTART,SDECSC,SDCLA) ;EP
+1 ;Called by SDEC ADD APPOINTMENT protocol
+2 ;SDECSC=IEN of clinic in ^SC
+3 ;SDCLA=IEN for ^SC(SDECSC,"S",SDECSTART,1,SDCLA). Use to get Length & Note
+4 ;
+5 NEW SDECNOD,SDECLEN,SDECAPPTID,SDECNODP,SDECWKIN,SDECRES
+6 if +$GET(SDECNOEV)
QUIT
+7 IF $DATA(^SDEC(409.831,"ALOC",SDECSC))
SET SDECRES=$ORDER(^SDEC(409.831,"ALOC",SDECSC,0))
+8 if '+$GET(SDECRES)
QUIT
+9 SET SDECNOD=$GET(^SC(SDECSC,"S",SDECSTART,1,SDCLA,0))
+10 if SDECNOD=""
QUIT
+11 SET SDECNODP=$GET(^DPT(DFN,"S",SDECSTART,0))
+12 SET SDECWKIN=""
+13 ;Purpose of Visit field of DPT Appointment subfile
if $PIECE(SDECNODP,U,7)=4
SET SDECWKIN="WALKIN"
+14 SET SDECLEN=$PIECE(SDECNOD,U,2)
+15 if '+SDECLEN
QUIT
+16 SET SDECEND=$$FMADD^XLFDT(SDECSTART,0,0,SDECLEN,0)
+17 ;alb/sat 665 add SDECLEN
SET SDECAPPTID=$$SDECADD^SDEC07(SDECSTART,SDECEND,DFN,SDECRES,SDECWKIN,,,,,SDECSC,,,,,,1,+SDECLEN)
+18 if '+SDECAPPTID
QUIT
+19 SET SDECNOTE=$PIECE(SDECNOD,U,4)
+20 IF SDECNOTE]""
DO SDECWP^SDEC07(SDECAPPTID,SDECNOTE)
+21 DO ADDEVT3(SDECRES)
+22 QUIT
+23 ;
ADDEVT3(SDECRES) ;
+1 ;Call RaiseEvent to notify GUI clients
+2 QUIT
+3 ;
+4 ;moved AVUPDT, DOW and DAY from SDEC07 because of XINDEX error for size pwc / SD*5.3*694
+5 ;
AVUPDT(SDCL,SDECSTART,SDECLEN) ;Update Clinic availability
+1 ;SEE SDM1
+2 NEW %,ABORT,SDNOT,Y,DFN,SDVAL
+3 NEW SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
+4 NEW X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I,SDECINC,SDPLUS
+5 ;,DFN=DFN ;renamed SDECPATID to DFN
SET Y=SDCL
+6 SET SL=$GET(^SC(+Y,"SL"))
SET X=$PIECE(SL,U,3)
SET STARTDAY=$SELECT($LENGTH(X):X,1:8)
SET SC=Y
SET SB=STARTDAY-1/100
SET X=$PIECE(SL,U,6)
SET HSI=$SELECT(X=1:X,X:X,1:4)
SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)
SET STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
SET SDDIF=$SELECT(HSI<3:8/HSI,1:2)
KILL Y
+7 ;Determine maximum days for scheduling
+8 SET SDMAX(1)=$PIECE($GET(^SC(+SC,"SDP")),U,2)
if 'SDMAX(1)
SET SDMAX(1)=365
+9 SET (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
+10 SET SDDATE=SDECSTART
+11 SET SDSDATE=SDDATE
SET SDDATE=SDDATE\1
1 ;
+1 SET CCXN=0
KILL MXOK,COV,SDPROT
if $GET(DFN)<0
QUIT
SET SC=+SC
+2 SET X1=DT
SET SDEDT=365
if $DATA(^SC(SC,"SDP"))
SET SDEDT=$PIECE(^SC(SC,"SDP"),"^",2)
+3 SET X2=SDEDT
DO C^%DTC
SET SDEDT=X
+4 SET Y=SDECSTART
EN1 SET (X,SD)=Y
SET SM=0
DO DOW
S IF '$DATA(^SC(SC,"ST",$PIECE(SD,"."),1))
SET SS=+$ORDER(^SC(+SC,"T"_Y,SD))
if SS'>0
QUIT
if ^(SS,1)=""
QUIT
SET ^SC(+SC,"ST",$PIECE(SD,"."),1)=$EXTRACT($PIECE($TEXT(DAY),U,Y+2),1,2)_" "_$EXTRACT(SD,6,7)_$JUSTIFY("",SI+SI-6)_^(1)
SET ^(0)=$PIECE(SD,".")
+1 SET S=SDECLEN
+2 ;Check if SDECLEN evenly divisible by appointment length
+3 SET SDVAL=$PIECE(SL,U)
+4 IF SDECLEN<SDVAL
SET SDECLEN=SDVAL
+5 IF SDECLEN#SDVAL'=0
Begin DoDot:1
+6 SET SDECINC=SDECLEN\SDVAL
+7 SET SDECINC=SDECINC+1
+8 SET SDECLEN=SDVAL*SDECINC
End DoDot:1
+9 SET SL=S_U_$PIECE(SL,U,2,99)
SC SET SDLOCK=$SELECT('$DATA(SDLOCK):1,1:SDLOCK+1)
if SDLOCK>9
QUIT
+1 LOCK +^SC(SC,"ST",$PIECE(SD,"."),1):5
if '$TEST
GOTO SC
+2 SET SDLOCK=0
SET S=^SC(SC,"ST",$PIECE(SD,"."),1)
+3 SET I=SD#1-SB*100
SET ST=I#1*SI\.6+($PIECE(I,".")*SI)
SET SS=SL*HSI/60*SDDIF+ST+ST
+4 IF (I<1!'$FIND(S,"["))&(S'["CAN")
LOCK -^SC(SC,"ST",$PIECE(SD,"."),1)
QUIT
+5 IF SM<7
SET %=$FIND(S,"[",SS-1)
if '%!($PIECE(SL,"^",6)<3)
SET %=999
IF $FIND(S,"]",SS)'<%!(SDDIF=2&$EXTRACT(S,ST+ST+1,SS-1)["[")
SET SM=7
+6 ;
SP IF ST+ST>$LENGTH(S)
IF $LENGTH(S)<80
SET S=S_" "
GOTO SP
+1 SET SDNOT=1
+2 SET ABORT=0
+3 FOR I=ST+ST:SDDIF:SS-SDDIF
Begin DoDot:1
+4 SET ST=$EXTRACT(S,I+1)
if ST=""
SET ST=" "
+5 SET Y=$EXTRACT(STR,$FIND(STR,ST)-2)
+6 IF S["CAN"!(ST="X"&($DATA(^SC(+SC,"ST",$PIECE(SD,"."),"CAN"))))
SET ABORT=1
QUIT
+7 IF Y=""
SET ABORT=1
QUIT
+8 if Y'?1NL&(SM<6)
SET SM=6
SET ST=$EXTRACT(S,I+2,999)
if ST=""
SET ST=" "
SET S=$EXTRACT(S,1,I)_Y_ST
End DoDot:1
if ABORT
QUIT
+9 SET ^SC(SC,"ST",$PIECE(SD,"."),1)=S
+10 LOCK -^SC(SC,"ST",$PIECE(SD,"."),1)
+11 QUIT
+12 ;
DOW NEW SDTMP
SET SDTMP=$EXTRACT(X,1,3)
SET Y=$EXTRACT(X,4,5)
SET Y=Y>2&'(SDTMP#4)+$EXTRACT("144025036146",Y)
+1 FOR SDTMP=SDTMP:-1:281
SET Y=SDTMP#4=1+1+Y
+2 SET Y=$EXTRACT(X,6,7)+Y#7
+3 QUIT
+4 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
+2 QUIT
ORDERLOCKCHECK(REQUESTYPE,APPTREQIEN,SDECI,DFN) ;
+1 ; sd*5.3*816 if RTC order cannot be locked then do not create appointment
+2 ; send back error message to client
+3 ;INPUT -
+4 ;REQUESTYPE - TYPE OF APPT REQUEST (e.g., APPT, RTC, VETERAN)
+5 ;APPTREQIEN - IEN of 409.85
+6 ;SDECI - Line counter for error array - passed in by reference
+7 ;DFN - ien of PATIENT file (#2)
+8 ; return ERROR = 0 or 1
+9 NEW ORDERID,ERROR,USER,LOCKFLG
+10 SET LOCKFLG=0
+11 SET ORDERID=$GET(ORDERID)
+12 SET ERROR=0
+13 IF REQUESTYPE="RTC"
Begin DoDot:1
+14 SET ORDERID=$$GET1^DIQ(409.85,APPTREQIEN,46,"I")
+15 if '+ORDERID
QUIT
+16 IF $DATA(^XTMP("ORLK-"_ORDERID))
Begin DoDot:2
+17 SET LOCKFLG=1
+18 SET USER=$$GET1^DIQ(200,$PIECE($GET(^XTMP("ORLK-"_ORDERID,1)),"^"),.01)
+19 DO ERR^SDEC07(SDECI+1,"RTC Order is being edited by "_USER_". Please try again later.",DFN,1)
SET ERROR=1
End DoDot:2
+20 IF LOCKFLG'=1
Begin DoDot:2
+21 SET LOCKFLG=$$LOCK1^ORX2(ORDERID)
+22 IF +LOCKFLG
Begin DoDot:3
+23 DO UNLK1^ORX2(ORDERID)
End DoDot:3
+24 IF '(+LOCKFLG)
Begin DoDot:3
+25 DO ERR^SDEC07(SDECI+1,"RTC Order is locked by another user. Please try again later.",DFN,1)
SET ERROR=1
+26 SET ERROR=1
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT ERROR
