Routine: SDWLE110

SDWLE110 ;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT ;1/11/16 10:32am

 ;;5.3;scheduling;**263,273,424,454,554,645**;AUG 13 1993;Build 7

 ;******************************************************************

 ;                             CHANGE LOG

 ;   DATE                        PATCH                   DESCRIPTION

 ;   ----                        -----                   -----------

 ;   11/27/02                  SD*5.3*273            Add "/", line SA1+11,+13,FA2+13

EN K DIR

 I $D(^SDWL(409.3,SDWLDA,0)) S DIR("B")=$$EXTERNAL^DILFD(409.3,10,,$P(^(0),U,11))

 I DIR("B")="" K DIR("B")

 S DIR(0)="SO^1:Future Date;2:ASAP"

 S DIR("L",1)="Priority",DIR("L",2)=""

 S DIR("L",3)="1. Future Date",DIR("L")="2. ASAP"

 D ^DIR I X["^" S DUOUT=1 Q  ;-'^' here will remove patient from wait list

 I X="@" W *7," ??" G EN

 I X="" W *7,"Required or '^' to quit." G EN

 I $D(DTOUT) S DUOUT=1 Q

 S X=$E(X,1)

 S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCEDFGHIJKLMNOPQRSTUVWXYZ")

 S SDWLPRIE=$S(X["A":"A",X["F":"F",X[1:"F",X[2:"A",1:"F")

 S DIE="^SDWL(409.3,",DA=SDWLDA,DR="10////^S X=SDWLPRIE" D ^DIE

 ;If priority is ASAP ask requesting provider

 I SDWLPRIE="A" S Y=DT D DD^%DT W " ",Y D SA,DUP G END:$D(DUOUT) Q

 I SDWLPRIE="F" D FA G END:$D(DUOUT) Q  ;to enter future date

SA K DIR,DR,DIE S SDWLERR=0,SDWLX=$S($D(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"")

 I $D(SDWLPROV),SDWLPROV,SDWLX'="" S DIR("B")=SDWLX

 I $D(^SDWL(409.3,SDWLDA,0)) S DIR("B")=$$EXTERNAL^DILFD(409.3,11,,$P(^(0),U,12))

 I DIR("B")="" K DIR("B")

 K %DT,DR S DIR(0)="SO^1:Provider;2:Patient"

 S DIR("L",1)="Request By",DIR("L",2)=""

 S DIR("L",3)="1. Provider",DIR("L")="2. Patient"

 D ^DIR I X["^" S DUOUT=1,DIR("A")="ASAP" Q

 S X=Y

 I $D(DTOUT) S DUOUT=1,DIR("A")="ASAP" Q

 S SDWLRBE=$S(X=1:1,X["PR":1,X["pr":1,X["Pr":1,X=2:2,X["PA":2,X["pa":2,X["Pa":2,1:0) I 'SDWLRBE W *7," ??" G SA

 S DR="11////^S X=SDWLRBE",DA=SDWLDA,DIE="^SDWL(409.3," D ^DIE

SA1 I SDWLRBE=1 D

 .S DIC("S")="I $$SCREEN^SDUTL2(Y,DT)"

 .S SDWLX=$S($D(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"") I SDWLX'="" S DIC("B")=SDWLPROV

 .I $D(^SDWL(409.3,SDWLDA,0)) S DIR("B")=$$EXTERNAL^DILFD(409.3,11,,$P(^(0),U,12))

 .S SDWLERR=0,DIC(0)="AEQ",DIC=200,DIC("A")="Provider Requesting Appointment: " D ^DIC

 .I X["^" S DUOUT=1 Q

 .I Y<1 S SDWLERR=1 Q

 .I $D(DUOUT) Q

 .I $D(DTOUT) S DUOUT=1 Q

 .K DIC,DIC("S"),DIC("A"),DIC(0),DIC("B")

 .S SDWLPROV=+Y,SDWLPRON=$P(Y,U,2),DIE="^SDWL(409.3,",DA=SDWLDA

 .S DR="12////^S X=SDWLPROV" D ^DIE S SDWLPRVE=SDWLPROV

 I SDWLERR W *7," Required" G SA1

 S DR="11////^S X=SDWLRBE" D ^DIE

 S DR="22///TODAY" D ^DIE K DIE,DR,DIC,DIR,SDWLPRVE,SDWLPROV,SDWLPRON

 ;If Priority is 'FUTURE' ask Desired Date of Appointment and Requesting by Provider or Patient

FA S SDWLERR=0 K DIR,DUOUT,DR,DIE I $D(SDWLDAPE) S Y=SDWLDAPE D DD^%DT S DIR("B")=Y

 I $D(^SDWL(409.3,SDWLDA,0)),$P(^(0),U,16) S %DT("B")=$$EXTERNAL^DILFD(409.3,22,,$P(^(0),U,16))  ;SD*5.3*424

 ; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user

 ;S %DT="AEF",%DT("A")="Desired Date of Appointment: " D ^%DT ; Added "F" to set to a future date - PATCH SD*5.3*554

 S %DT="AEF",%DT("A")="CID/Preferred Date of Appointment: " D ^%DT

 I $D(DTOUT)!(X="^") G EN

 I X="" W *7,!!,"This is a required response. Enter '^' to exit.",! G EN  ;SD*5.3*454

 S SDWLDAPE=Y,DR="22////^S X=SDWLDAPE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE

 K SDWLDAPE,Y,DA,DIE,%DT,%DT(0),%DT("A"),%DT("B")

FA1 K DIR,%DT,DR S DIR(0)="SO^1:Provider;2:Patient"

 S SDWLX=$S($D(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"") I SDWLX'="" S DIR("B")=SDWLPROV

 I $D(^SDWL(409.3,SDWLDA,0)) S DIR("B")=$$EXTERNAL^DILFD(409.3,11,,$P(^(0),U,12))

 I DIR("B")="" K DIR("B")

 S DIR("L",1)="Request By",DIR("L",2)=""

 S DIR("L",3)="1. Provider",DIR("L")="2. Patient"

 D ^DIR I X["^" S DIR("B")=$S($D(SDWLDAPE):SDWLDAPE,1:"") G FA

 S X=Y

 I $D(DTOUT) S DUOUT=1 S DIR("B")=SDWLDAPE G FA

 S SDWLRBE=$S(X=1:1,X["PR":1,X["pr":1,X["Pr":1,X=2:2,X["PA":2,X["pa":2,X["Pa":2,1:0) I 'SDWLRBE W *7," ??" G FA1

 S DR="11////^S X=SDWLRBE",DA=SDWLDA,DIE="^SDWL(409.3," D ^DIE

FA2 I SDWLRBE=1 D

.;

 .;if provider is selected look-up valid provider from new person (File 200)

.;

 .S DIC("S")="I $$SCREEN^SDUTL2(Y,DT)"

 .S SDWLX=$S($D(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:""),DIC("B")=$S($D(SDWLPROV):SDWLX,1:"")

 .S SDWLERR=0,DIC(0)="AEQ",DIC=200,DIC("A")="Provider Requesting Appointment: " D ^DIC

 .I X["^" S DUOUT=1 Q

 .I Y<1 S SDWLERR=1 Q

 .I $D(DTOUT) S DUOUT=1 Q

 .Q:$D(DUOUT)  D

 ..K DIC,DIC("S"),DIC("A"),DIC(0),DIC("B")

 ..S SDWLPROV=+Y,SDWLPRON=$P(Y,U,2),DIE="^SDWL(409.3,",DA=SDWLDA

 ..S DR="12////^S X=SDWLPROV" D ^DIE S SDWLPRVE=SDWLPROV K DIE

 I SDWLERR W *7," Required" G FA2

END K DIC,DIE,DIR I $D(DUOUT) S DIR("B")=$S(SDWLPRIE="F":"Future",1:"ASAP")

 K SDWLPRVE,SDWLPROV,SDWLPRON

DUP ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLE110   5032     printed  Feb 19, 2025@00:28:56                                                                                                                                                                                                    Page 2

SDWLE110  ;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT ;1/11/16 10:32am

 +1       ;;5.3;scheduling;**263,273,424,454,554,645**;AUG 13 1993;Build 7

 +2       ;

 +3       ;

 +4       ;******************************************************************

 +5       ;                             CHANGE LOG

 +6       ;

 +7       ;   DATE                        PATCH                   DESCRIPTION

 +8       ;   ----                        -----                   -----------

 +9       ;   11/27/02                  SD*5.3*273            Add "/", line SA1+11,+13,FA2+13

 +10      ;

 +11      ;

EN         KILL DIR

 +1        IF $DATA(^SDWL(409.3,SDWLDA,0))

               SET DIR("B")=$$EXTERNAL^DILFD(409.3,10,,$PIECE(^(0),U,11))

 +2        IF DIR("B")=""

               KILL DIR("B")

 +3        SET DIR(0)="SO^1:Future Date;2:ASAP"

 +4        SET DIR("L",1)="Priority"

           SET DIR("L",2)=""

 +5        SET DIR("L",3)="1. Future Date"

           SET DIR("L")="2. ASAP"

 +6       ;-'^' here will remove patient from wait list

           DO ^DIR

           IF X["^"

               SET DUOUT=1

               QUIT

 +7        IF X="@"

               WRITE *7," ??"

               GOTO EN

 +8        IF X=""

               WRITE *7,"Required or '^' to quit."

               GOTO EN

 +9        IF $DATA(DTOUT)

               SET DUOUT=1

               QUIT

 +10       SET X=$EXTRACT(X,1)

 +11       SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCEDFGHIJKLMNOPQRSTUVWXYZ")

 +12       SET SDWLPRIE=$SELECT(X["A":"A",X["F":"F",X[1:"F",X[2:"A",1:"F")

 +13       SET DIE="^SDWL(409.3,"

           SET DA=SDWLDA

           SET DR="10////^S X=SDWLPRIE"

           DO ^DIE

 +14      ;

 +15      ;If priority is ASAP ask requesting provider

 +16      ;

 +17       IF SDWLPRIE="A"

               SET Y=DT

               DO DD^%DT

               WRITE " ",Y

               DO SA

               DO DUP

               if $DATA(DUOUT)

                   GOTO END

               QUIT

 +18      ;to enter future date

           IF SDWLPRIE="F"

               DO FA

               if $DATA(DUOUT)

                   GOTO END

               QUIT

 +19       QUIT

 +20      ;

SA         KILL DIR,DR,DIE

           SET SDWLERR=0

           SET SDWLX=$SELECT($DATA(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"")

 +1        IF $DATA(SDWLPROV)

               IF SDWLPROV

                   IF SDWLX'=""

                       SET DIR("B")=SDWLX

 +2        IF $DATA(^SDWL(409.3,SDWLDA,0))

               SET DIR("B")=$$EXTERNAL^DILFD(409.3,11,,$PIECE(^(0),U,12))

 +3        IF DIR("B")=""

               KILL DIR("B")

 +4        KILL %DT,DR

           SET DIR(0)="SO^1:Provider;2:Patient"

 +5        SET DIR("L",1)="Request By"

           SET DIR("L",2)=""

 +6        SET DIR("L",3)="1. Provider"

           SET DIR("L")="2. Patient"

 +7        DO ^DIR

           IF X["^"

               SET DUOUT=1

               SET DIR("A")="ASAP"

               QUIT

 +8        SET X=Y

 +9        IF $DATA(DTOUT)

               SET DUOUT=1

               SET DIR("A")="ASAP"

               QUIT

 +10       SET SDWLRBE=$SELECT(X=1:1,X["PR":1,X["pr":1,X["Pr":1,X=2:2,X["PA":2,X["pa":2,X["Pa":2,1:0)

           IF 'SDWLRBE

               WRITE *7," ??"

               GOTO SA

 +11       SET DR="11////^S X=SDWLRBE"

           SET DA=SDWLDA

           SET DIE="^SDWL(409.3,"

           DO ^DIE

 +12      ;

SA1        IF SDWLRBE=1

               Begin DoDot:1

 +1                SET DIC("S")="I $$SCREEN^SDUTL2(Y,DT)"

 +2                SET SDWLX=$SELECT($DATA(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"")

                   IF SDWLX'=""

                       SET DIC("B")=SDWLPROV

 +3                IF $DATA(^SDWL(409.3,SDWLDA,0))

                       SET DIR("B")=$$EXTERNAL^DILFD(409.3,11,,$PIECE(^(0),U,12))

 +4                SET SDWLERR=0

                   SET DIC(0)="AEQ"

                   SET DIC=200

                   SET DIC("A")="Provider Requesting Appointment: "

                   DO ^DIC

 +5                IF X["^"

                       SET DUOUT=1

                       QUIT

 +6                IF Y<1

                       SET SDWLERR=1

                       QUIT

 +7                IF $DATA(DUOUT)

                       QUIT

 +8                IF $DATA(DTOUT)

                       SET DUOUT=1

                       QUIT

 +9                KILL DIC,DIC("S"),DIC("A"),DIC(0),DIC("B")

 +10               SET SDWLPROV=+Y

                   SET SDWLPRON=$PIECE(Y,U,2)

                   SET DIE="^SDWL(409.3,"

                   SET DA=SDWLDA

 +11               SET DR="12////^S X=SDWLPROV"

                   DO ^DIE

                   SET SDWLPRVE=SDWLPROV

               End DoDot:1

 +12       IF SDWLERR

               WRITE *7," Required"

               GOTO SA1

 +13       SET DR="11////^S X=SDWLRBE"

           DO ^DIE

 +14       SET DR="22///TODAY"

           DO ^DIE

           KILL DIE,DR,DIC,DIR,SDWLPRVE,SDWLPROV,SDWLPRON

 +15       QUIT

 +16      ;

 +17      ;If Priority is 'FUTURE' ask Desired Date of Appointment and Requesting by Provider or Patient

 +18      ;

FA         SET SDWLERR=0

           KILL DIR,DUOUT,DR,DIE

           IF $DATA(SDWLDAPE)

               SET Y=SDWLDAPE

               DO DD^%DT

               SET DIR("B")=Y

 +1       ;SD*5.3*424

           IF $DATA(^SDWL(409.3,SDWLDA,0))

               IF $PIECE(^(0),U,16)

                   SET %DT("B")=$$EXTERNAL^DILFD(409.3,22,,$PIECE(^(0),U,16))

 +2       ; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user

 +3       ;S %DT="AEF",%DT("A")="Desired Date of Appointment: " D ^%DT ; Added "F" to set to a future date - PATCH SD*5.3*554

 +4        SET %DT="AEF"

           SET %DT("A")="CID/Preferred Date of Appointment: "

           DO ^%DT

 +5        IF $DATA(DTOUT)!(X="^")

               GOTO EN

 +6       ;SD*5.3*454

           IF X=""

               WRITE *7,!!,"This is a required response. Enter '^' to exit.",!

               GOTO EN

 +7        SET SDWLDAPE=Y

           SET DR="22////^S X=SDWLDAPE"

           SET DIE="^SDWL(409.3,"

           SET DA=SDWLDA

           DO ^DIE

 +8        KILL SDWLDAPE,Y,DA,DIE,%DT,%DT(0),%DT("A"),%DT("B")

 +9       ;

FA1        KILL DIR,%DT,DR

           SET DIR(0)="SO^1:Provider;2:Patient"

 +1        SET SDWLX=$SELECT($DATA(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"")

           IF SDWLX'=""

               SET DIR("B")=SDWLPROV

 +2        IF $DATA(^SDWL(409.3,SDWLDA,0))

               SET DIR("B")=$$EXTERNAL^DILFD(409.3,11,,$PIECE(^(0),U,12))

 +3        IF DIR("B")=""

               KILL DIR("B")

 +4        SET DIR("L",1)="Request By"

           SET DIR("L",2)=""

 +5        SET DIR("L",3)="1. Provider"

           SET DIR("L")="2. Patient"

 +6        DO ^DIR

           IF X["^"

               SET DIR("B")=$SELECT($DATA(SDWLDAPE):SDWLDAPE,1:"")

               GOTO FA

 +7        SET X=Y

 +8        IF $DATA(DTOUT)

               SET DUOUT=1

               SET DIR("B")=SDWLDAPE

               GOTO FA

 +9        SET SDWLRBE=$SELECT(X=1:1,X["PR":1,X["pr":1,X["Pr":1,X=2:2,X["PA":2,X["pa":2,X["Pa":2,1:0)

           IF 'SDWLRBE

               WRITE *7," ??"

               GOTO FA1

 +10       SET DR="11////^S X=SDWLRBE"

           SET DA=SDWLDA

           SET DIE="^SDWL(409.3,"

           DO ^DIE

 +11      ;

FA2        IF SDWLRBE=1

               Begin DoDot:1

 +1       ;

 +2       ;if provider is selected look-up valid provider from new person (File 200)

 +3       ;

 +4                SET DIC("S")="I $$SCREEN^SDUTL2(Y,DT)"

 +5                SET SDWLX=$SELECT($DATA(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"")

                   SET DIC("B")=$SELECT($DATA(SDWLPROV):SDWLX,1:"")

 +6                SET SDWLERR=0

                   SET DIC(0)="AEQ"

                   SET DIC=200

                   SET DIC("A")="Provider Requesting Appointment: "

                   DO ^DIC

 +7                IF X["^"

                       SET DUOUT=1

                       QUIT

 +8                IF Y<1

                       SET SDWLERR=1

                       QUIT

 +9                IF $DATA(DTOUT)

                       SET DUOUT=1

                       QUIT

 +10               if $DATA(DUOUT)

                       QUIT

                   Begin DoDot:2

 +11                   KILL DIC,DIC("S"),DIC("A"),DIC(0),DIC("B")

 +12                   SET SDWLPROV=+Y

                       SET SDWLPRON=$PIECE(Y,U,2)

                       SET DIE="^SDWL(409.3,"

                       SET DA=SDWLDA

 +13                   SET DR="12////^S X=SDWLPROV"

                       DO ^DIE

                       SET SDWLPRVE=SDWLPROV

                       KILL DIE

                   End DoDot:2

               End DoDot:1

 +14       IF SDWLERR

               WRITE *7," Required"

               GOTO FA2

END        KILL DIC,DIE,DIR

           IF $DATA(DUOUT)

               SET DIR("B")=$SELECT(SDWLPRIE="F":"Future",1:"ASAP")

 +1        KILL SDWLPRVE,SDWLPROV,SDWLPRON

 +2        QUIT

 +3       ;

DUP       ;

 +1        QUIT

SDWLE110.m