Routine: SDEC07C

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

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)

ADDEVT3(SDECRES) ;

 ;Call RaiseEvent to notify GUI clients

 ;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)

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

DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR

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  Mar 13, 2025@21:55:01                                                                                                                                                                                                     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

SDEC07C.m