Routine: SDWLEVAL

SDWLEVAL ;;IOFO BAY PINES/ESW - WAIT LIST - DISPOSITION AFTER APPOINTMENT(S) ENTRY;12/11/08 5:11pm  ; Compiled March 6, 2009 11:11:50

 ;;5.3;Scheduling;**327,471,446,538**;AUG 13 1993;Build 5

 ;Evaluate appt for optional disposition

 ;called from SDMM, SDMM1, SDM1A, SDAM2 ; replaced SDWLR

EN(DFN,SDYN) ;evaluation if patient is on EWL

 ; SDYN passed by reference

 ;output: SDYN=0 -  no open entries in EWL

 ;        SDYN=1 -  at least one open entry in EWL

 S SDYN=0,SDYN(1)=""

 I '$D(DFN)!(DFN'?1.N) S SDYN(1)="Patient's DFN not passed." Q

 I $D(DFN),'$D(^SDWL(409.3,"B",DFN)) S SDYN(1)="This patient is not on EWL." Q

 S SDWLDA="" F  S SDWLDA=$O(^SDWL(409.3,"B",DFN,SDWLDA)) Q:SDWLDA=""  D  Q:SDYN=1

 .I $P($G(^SDWL(409.3,SDWLDA,0)),"^",17)="O" S SDYN=1,SDYN(1)="Patient has open Wait List entries."

 I SDYN=0 S SDYN(1)="Patient has no open Wait List entries."

EWLANS(SDCONT) ;display EWL OPEN entries

 ;check if to continue with EWL open entries

 S SDCONT=0

 N X,DIR,Y

 S DIR("B")="NO"

 S DIR("A")="Do you want to display open Wait list entries (Yes/No)?",DIR(0)="Y"

 S DIR("?")="Do you want to review open EWL entries for Dispositioning?"

 D ^DIR

 I Y S SDCONT=1

ASKREM ;prompt user for record for dispositioning

 S SDDIS=0 ; flag indicating disposition

 W ! N X,DIR,Y

 S DIR("B")="NO"

 S DIR("A")="DO YOU WISH TO REMOVE ANY ENTRY FROM LIST (Yes/No)? ",DIR(0)="Y"

 S DIR("?")="To disposition any entry based on scheduled appointments."

 D ^DIR

 I Y S SDDIS=1

 D ANSW(SDDIS)

ANSW(SDDIS,SDR) ;

 ;SDDIS=0 - select entries not to disposition

 ;SDDIS=1 - select entries to disposition

 N DIR,X I '$D(SDR) S SDR=1

W !

 N STR,SS,SDCB S SDC=$O(^TMP($J,"SDWLPL",""),-1),SDCB=$O(^TMP($J,"SDWLPL",""))

 ;I SDC=SDCB S DIR("B")=SDC

 ;E  S DIR("B")=SDCB_"-"_SDC

 S DIR(0)="LO^"_SDCB_":"_SDC_"^"_"K:X=""^"" X" S DIR("A")="Select EWL entry to enter a non-removal reason or press 'Enter' key to accept the current one(s): "

 S DIR("?")="Enter number(s) or range of displayed Wait List entries or press 'Enter' key to accept the present non-removal reason."

 I SDDIS S DIR("A")="Select one of the above open EWL entries to close with an appointment or press 'Enter' key to continue>"

 D ^DIR

 N SDAN S SDAN=X I SDAN="^" W " YOU CANNOT EXIT HERE" Q

 I SDAN["-" D

 .N SXB,SXE

 .S SXB=$P(SDAN,"-"),SXE=$P(SDAN,"-",2) N SDC F SDC=SXB:1:SXE I $D(^TMP($J,"SDWLPL",SDC)) S SDWLDA=+^TMP($J,"SDWLPL",SDC) D

 ..;LOCK

 ..L +^SDWL(409.3,SDWLDA):5 I '$T W !,"Another User is Editing this Entry. Try Later." Q

 ..I 'SDDIS N SDR F  D DISPO(SDWLDA,SDC,.SDR) Q:SDR

 ..I SDDIS D GETDATA(SDWLDA) D DISEND(SDWLDA,SDC) S SDR=1

..L

 I 'SDDIS I SDAN=""&(SDCB=SDC) I $P($G(REC),U,13)="" S SDAN=SDC ;;;;;

 I SDAN="" D

 .I SDDIS S SDR=0 Q

 .N SDC,SDRN,SDWLDA,SDWLDS S SDC="",SDR=0 F  S SDC=$O(^TMP($J,"SDWLPL",SDC)) Q:SDC=""  S SDWLDS=^TMP($J,"SDWLPL",SDC),SDWLDA=+SDWLDS D

 ..I $P(SDWLDS,U,13)'="" K ^TMP($J,"SDWLPL",SDC)

 .I '$D(^TMP($J,"SDWLPL")) S SDR=1

 I SDAN[","!(SDAN?1N) D

 .N FF S FF=SDAN N GG,SDC F GG=1:1 S SDC=$P(FF,",",GG) Q:SDC=""  I $D(^TMP($J,"SDWLPL",SDC)) S SDWLDA=+^TMP($J,"SDWLPL",SDC) D

 ..;LOCK

 ..L +^SDWL(409.3,SDWLDA):5 I '$T W !,"Another User is Editing this Entry. Try Later." Q

 ..I 'SDDIS N SDR F  D DISPO(SDWLDA,SDC,.SDR) Q:SDR

 ..I SDDIS D GETDATA(SDWLDA) D DISEND(SDWLDA,SDC) S SDR=1

..L

DISEND(SDWLDA,SDC) ;display and disposition

 ;SDWLDA - IEN of 409.3

 N DUOUT D EDIT(SDWLDA,SDC,.SDWLERR) Q:$G(DUOUT)  I SDWLERR Q

 W !!,"*** Patient has been removed from Wait List ***",!

 K ^TMP($J,"SDWLPL",SDC)

 K DIR,DIE,DR,DIC

GETDATA(SDWLDA) ;retrieval data

 N SDWLCL,SDWLDAPT,SDWLDATA,SDWLDISP,SDWLDUZ,SDWLEDT,SDWLIN,SDWLPRI,SDWLPROV,SDWLRB,SDWLSC,SDWLSP,SDWLST,SDWLTY

 S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0))

 S SDWLIN=$P(SDWLDATA,U,3),SDWLCL=+$P(SDWLDATA,U,4),SDWLTY=$P(SDWLDATA,U,5),SDWLST=$P(SDWLDATA,U,6)

 S SDWLSP=$P(SDWLDATA,U,7),SDWLSS=$P(SDWLDATA,U,8),SDWLSC=$P(SDWLDATA,U,9),SDWLPRI=$P(SDWLDATA,U,10),SDWLRB=$P(SDWLDATA,U,11)

 S SDWLPROV=$P(SDWLDATA,U,12),SDWLDAPT=$P(SDWLDATA,U,16),SDWLST=$P(SDWLDATA,U,17),SDWLDUZ=DUZ,SDWLEDT=DT

 S SDWLSCL="" I SDWLSC S SDWLSCL=+$P(^SDWL(409.32,SDWLSC,0),U,1)

 I $D(^SDWL(409.3,SDWLDA,"DIS")) S SDWLDISP=$P(^SDWL(409.3,SDWLDA,"DIS"),U,3)

EDIT(SDWLDA,SDC,SDWLERR) ;ENTER/EDIT DISPOSITION

 ;SDWLDA -IEN of selected 409.3 entry

 ;SDWLERR - called by a reference

 ;SDC - sequential number in ^TMP($J,"SDWLPL",SDC

 S SDWLDUZ=DUZ,SDWLERR=0 S SDWLDISP="SA" D EDITSA Q  ;N DIR,DR,DIE,DIC

EDITSA I SDWLDISP="SA" D

 .I $O(^TMP($J,"APPT",""))=$O(^TMP($J,"APPT",""),-1) S SDAP=$O(^TMP($J,"APPT","")) Q

 .I $O(^TMP($J,"APPT",""))'=$O(^TMP($J,"APPT",""),-1) D APPTD D  I SDAP="C" W !,"Disposition canceled by user",! Q

 ..W ! K DIR,X

 ..N STR,SS,SDA S SDA=$O(^TMP($J,"APPT",""),-1) I SDA=1 S DIR("B")=1

 ..S DIR(0)="N^1:"_SDA S DIR("A")="Select appt for Removal Reason or 'C' to Quit>",DIR("?")="Select Appointment to close with the open EWL."

 ..D ^DIR

 ..S SDAP=X

 S DIE="^SDWL(409.3,",DA=SDWLDA,DR="21////^S X=SDWLDISP" D ^DIE

 S DR="19////^S X=DT" D ^DIE

 S DR="20////^S X=SDWLDUZ" D ^DIE

 S DR="23////^S X=""C""" D ^DIE

 ;if "SA" update with appoint data

 ;get appt data to file (for a particular appt #)

 I SDWLDISP="SA" N SDA D DATP(SDAP,.SDA) D

 .I $D(SDA) S DIE="^SDWL(409.3,",DA=SDWLDA D

 ..S DR="13////"_SDA(1)_";13.1////"_DT_";13.2////"_SDA(2)_";13.3////"_SDA(15)_";13.4////"_SDA(13)_";13.5////"_SDA(14)_";13.6////"_SDA(16)_";13.8////"_SDA(3)_";13.7////"_DUZ

 ..D ^DIE

 N SDWLSCL,SDWLSS,SDWLDFN

 S SDWLSCL=$P($G(^TMP($J,"SDWLPL",SDC)),U,9)

 S SDWLSS=$P($G(^TMP($J,"SDWLPL",SDC)),U,10)

 I SDWLSCL K:$D(^SDWL(409.3,"SC",SDWLSCL,SDWLDA)) ^SDWL(409.3,"SC",SDWLSCL,SDWLDA)

 S SDWLDFN=$P($G(^TMP($J,"APPT",1)),U,4)

 I SDWLSS,SDWLDFN K:$D(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)) ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)

DISPO(SDWLDA,SDC,SDR) ;

 ;SDWLDA - IEN of 409.3

 ;SDC - seq in ^TMP($J,"SDWLPL",SDC

 ;out SDR - NON REMOVAL:

 ; 1 entered

 ; 0 not entered

 K DIR,X S SDR=0

 S DIR(0)="SM^1:APPOINTMENT CRITERIA NOT MET;2:PATIENT WANTS ANOTHER APPOINTMENT;3:PROVIDER WANTS ANOTHER APPOINTMENT;4:OTHER"

 S DIR("L",1)="SELECT ONE OF THE FOLLOWING REASONS FOR # "_SDC_":",DIR("L",2)=""

 S DIR("L",3)="1. APPOINTMENT CRITERIA NOT MET",DIR("L",4)="2. PATIENT WANTS ANOTHER APPOINTMENT"

 S DIR("L",5)="3. PROVIDER WANTS ANOTHER APPOINTMENT",DIR("L,6")="4. OTHER"

 S DIR("A")="Select one of the following reasons for #: "_SDC

 D ^DIR

 S X=$E(X,1,2) S:$E(X,2)'="R" X=$E(X)

 S SDWLX=$S(X="a":"A",X="p":"P",X="pr":"PR",X="o":"O",X="A":"A",X="P":"P",X="PR":"PR",X="O":"O",X=1:"A",X=2:"P",X=3:"PR",X=4:"O",1:"^")

 I SDWLX="^" Q

 S SDR=1

 I SDWLX="O" D

 .S DIR(0)="FAO^^",DIR("A")="Comments: " D ^DIR Q:X["^"

 .S SDWLCOM=X,DA=SDWLDA,DIE="^SDWL(409.3,",DR="18.1////^S X=SDWLCOM" D ^DIE

 N DA S DA=SDWLDA

 S DIE="^SDWL(409.3,",DR="18////^S X=SDWLX" D ^DIE

 S DR="17////^S X=DUZ" D ^DIE

 S DR="16////^S X=DT" D ^DIE

 K SDWLERR,DIR,DR,DIE,X,SDWLX,SDWLDSS,SDWLASK,SDWLDA,SDWLCOM

 K ^TMP($J,"SDWLPL",SDC)

HD ;HEADER

 W:$D(IOF) @IOF W !!,?80-$L("Wait List - Disposition Patient")\2,"Wait List - Disposition Patient",!!

APPT(DFN,SD,SC) ;create appt TMP

 ;SD - appt date/time

 ;SC - clinic IEN

 N SDARR,SCNT

 S SDDIV=""

 S SDARR(1)=SD_";"_SD

 S SDARR(2)=SC

 S SDARR(4)=DFN

 S SDARR("FLDS")="1;2;3;4;10;13;14;17"

 N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D

 .N SDINST,SDFAC,SDINSTE

 .Q:'$D(^TMP($J,"SDAMA301",DFN))

 .S SCNT=$O(^TMP($J,"APPT",""),-1)+1

 .S ^TMP($J,"APPT",SCNT)=^TMP($J,"SDAMA301",DFN,SC,SD)

 .N SDCLIN S SDCLIN=$$CLIN^SDWLBACC(SC),SDINST=$P(SDCLIN,U),SDFAC=$P(SDCLIN,U,2),SDINSTE=$P(SDCLIN,U,3)

 .S $P(^TMP($J,"APPT",SCNT),"^",15)=SDINST_";"_SDINSTE

 .S $P(^TMP($J,"APPT",SCNT),"^",16)=SDFAC

 .K ^TMP($J,"SDAMA301",DFN,SC,SD)

APPTD ;display appt

 ;from ^TMP($J,"APPT")

 N STR,SCNT

 Q:'$D(^TMP($J,"APPT"))

 S SCNT="" F  S SCNT=$O(^TMP($J,"APPT",SCNT)) Q:SCNT=""  D

 .S STR=^TMP($J,"APPT",SCNT)

 .N ZZ F ZZ=2,3,4,10,15 S SDD(ZZ)=$P($P(STR,"^",ZZ),";",2)

 .N SD S SD=$P(STR,U) D  S Y=SD D D^DIQ S SDD(1)=Y ; date conv

 ..I SDD(3)="SCHEDULED/KEPT" S SDD(3)=";"_$S(SD<DT:"KEPT",1:"SCHEDULED")

 .S SDD(16)=$P(STR,U,16)

 .N CP,ZZ F ZZ=13,14 S CP(ZZ)=$P($P(STR,U,ZZ),";") D

 ..S SDD(ZZ)=""

 ..I CP(ZZ)>0 S SDD(ZZ)=$$GET1^DIQ(40.7,CP(ZZ)_",",.01,"I") ; stop code desc

 .;DISPLAY

 .I SCNT=1 D DPH(SCNT,.SDD)

 .D DPHD(SCNT,.SDD)

W !

DATP(SCNT,SDA) ;

 ;SDA - to return APPT array

 S STR=^TMP($J,"APPT",SCNT)

 S SDA(1)=$P(STR,U)

 N ZZ F ZZ=2,3,10,13,14,15 S SDA(ZZ)=$P($P(STR,"^",ZZ),";",1)

 S SDA(16)=$P(STR,"^",16) ;station

DPH(SCNT,SDD) ;display appt header

 W !!,"Appointment(s) for: "_SDD(4) W !!?4,"Specialty: "_SDD(13),?60,"Station: ",SDD(16),!

 W !?3,"Appt Date/Time",?23,"Clinic",?48,"Status",?60,"Institution",! N SDL S $P(SDL,"-",79)="" W SDL,!

DPHD(SCNT,SDD) ;

 W !,SCNT,?3,SDD(1),?23,$E(SDD(2),1,23),?48,$E(SDD(10),1,10),?60,SDD(15)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLEVAL   8996     printed  Feb 19, 2025@00:29:07                                                                                                                                                                                                    Page 2

SDWLEVAL  ;;IOFO BAY PINES/ESW - WAIT LIST - DISPOSITION AFTER APPOINTMENT(S) ENTRY;12/11/08 5:11pm  ; Compiled March 6, 2009 11:11:50

 +1       ;;5.3;Scheduling;**327,471,446,538**;AUG 13 1993;Build 5

 +2       ;Evaluate appt for optional disposition

 +3       ;called from SDMM, SDMM1, SDM1A, SDAM2 ; replaced SDWLR

 +4       ;

EN(DFN,SDYN) ;evaluation if patient is on EWL

 +1       ; SDYN passed by reference

 +2       ;output: SDYN=0 -  no open entries in EWL

 +3       ;        SDYN=1 -  at least one open entry in EWL

 +4        SET SDYN=0

           SET SDYN(1)=""

 +5        IF '$DATA(DFN)!(DFN'?1.N)

               SET SDYN(1)="Patient's DFN not passed."

               QUIT

 +6        IF $DATA(DFN)

               IF '$DATA(^SDWL(409.3,"B",DFN))

                   SET SDYN(1)="This patient is not on EWL."

                   QUIT

 +7        SET SDWLDA=""

FOR

               SET SDWLDA=$ORDER(^SDWL(409.3,"B",DFN,SDWLDA))

               if SDWLDA=""

                   QUIT

               Begin DoDot:1

 +8                IF $PIECE($GET(^SDWL(409.3,SDWLDA,0)),"^",17)="O"

                       SET SDYN=1

                       SET SDYN(1)="Patient has open Wait List entries."

               End DoDot:1

               if SDYN=1

                   QUIT

 +9        IF SDYN=0

               SET SDYN(1)="Patient has no open Wait List entries."

 +10       QUIT

EWLANS(SDCONT) ;display EWL OPEN entries

 +1       ;check if to continue with EWL open entries

 +2        SET SDCONT=0

 +3        NEW X,DIR,Y

 +4        SET DIR("B")="NO"

 +5        SET DIR("A")="Do you want to display open Wait list entries (Yes/No)?"

           SET DIR(0)="Y"

 +6        SET DIR("?")="Do you want to review open EWL entries for Dispositioning?"

 +7        DO ^DIR

 +8        IF Y

               SET SDCONT=1

 +9        QUIT

ASKREM    ;prompt user for record for dispositioning

 +1       ; flag indicating disposition

           SET SDDIS=0

 +2        WRITE !

           NEW X,DIR,Y

 +3        SET DIR("B")="NO"

 +4        SET DIR("A")="DO YOU WISH TO REMOVE ANY ENTRY FROM LIST (Yes/No)? "

           SET DIR(0)="Y"

 +5        SET DIR("?")="To disposition any entry based on scheduled appointments."

 +6        DO ^DIR

 +7        IF Y

               SET SDDIS=1

 +8        DO ANSW(SDDIS)

 +9        QUIT

ANSW(SDDIS,SDR) ;

 +1       ;SDDIS=0 - select entries not to disposition

 +2       ;SDDIS=1 - select entries to disposition

 +3        NEW DIR,X

           IF '$DATA(SDR)

               SET SDR=1

 +4        WRITE !

 +5        NEW STR,SS,SDCB

           SET SDC=$ORDER(^TMP($JOB,"SDWLPL",""),-1)

           SET SDCB=$ORDER(^TMP($JOB,"SDWLPL",""))

 +6       ;I SDC=SDCB S DIR("B")=SDC

 +7       ;E  S DIR("B")=SDCB_"-"_SDC

 +8        SET DIR(0)="LO^"_SDCB_":"_SDC_"^"_"K:X=""^"" X"

           SET DIR("A")="Select EWL entry to enter a non-removal reason or press 'Enter' key to accept the current one(s): "

 +9        SET DIR("?")="Enter number(s) or range of displayed Wait List entries or press 'Enter' key to accept the present non-removal reason."

 +10       IF SDDIS

               SET DIR("A")="Select one of the above open EWL entries to close with an appointment or press 'Enter' key to continue>"

 +11       DO ^DIR

 +12       NEW SDAN

           SET SDAN=X

           IF SDAN="^"

               WRITE " YOU CANNOT EXIT HERE"

               QUIT

 +13       IF SDAN["-"

               Begin DoDot:1

 +14               NEW SXB,SXE

 +15               SET SXB=$PIECE(SDAN,"-")

                   SET SXE=$PIECE(SDAN,"-",2)

                   NEW SDC

                   FOR SDC=SXB:1:SXE

                       IF $DATA(^TMP($JOB,"SDWLPL",SDC))

                           SET SDWLDA=+^TMP($JOB,"SDWLPL",SDC)

                           Begin DoDot:2

 +16      ;LOCK

 +17                           LOCK +^SDWL(409.3,SDWLDA):5

                               IF '$TEST

                                   WRITE !,"Another User is Editing this Entry. Try Later."

                                   QUIT

 +18                           IF 'SDDIS

                                   NEW SDR

FOR

                                       DO DISPO(SDWLDA,SDC,.SDR)

                                       if SDR

                                           QUIT

 +19                           IF SDDIS

                                   DO GETDATA(SDWLDA)

                                   DO DISEND(SDWLDA,SDC)

                                   SET SDR=1

 +20                           LOCK

                           End DoDot:2

               End DoDot:1

 +21      ;;;;;

           IF 'SDDIS

               IF SDAN=""&(SDCB=SDC)

                   IF $PIECE($GET(REC),U,13)=""

                       SET SDAN=SDC

 +22       IF SDAN=""

               Begin DoDot:1

 +23               IF SDDIS

                       SET SDR=0

                       QUIT

 +24               NEW SDC,SDRN,SDWLDA,SDWLDS

                   SET SDC=""

                   SET SDR=0

FOR

                       SET SDC=$ORDER(^TMP($JOB,"SDWLPL",SDC))

                       if SDC=""

                           QUIT

                       SET SDWLDS=^TMP($JOB,"SDWLPL",SDC)

                       SET SDWLDA=+SDWLDS

                       Begin DoDot:2

 +25                       IF $PIECE(SDWLDS,U,13)'=""

                               KILL ^TMP($JOB,"SDWLPL",SDC)

                       End DoDot:2

 +26               IF '$DATA(^TMP($JOB,"SDWLPL"))

                       SET SDR=1

               End DoDot:1

 +27       IF SDAN[","!(SDAN?1N)

               Begin DoDot:1

 +28               NEW FF

                   SET FF=SDAN

                   NEW GG,SDC

                   FOR GG=1:1

                       SET SDC=$PIECE(FF,",",GG)

                       if SDC=""

                           QUIT

                       IF $DATA(^TMP($JOB,"SDWLPL",SDC))

                           SET SDWLDA=+^TMP($JOB,"SDWLPL",SDC)

                           Begin DoDot:2

 +29      ;LOCK

 +30                           LOCK +^SDWL(409.3,SDWLDA):5

                               IF '$TEST

                                   WRITE !,"Another User is Editing this Entry. Try Later."

                                   QUIT

 +31                           IF 'SDDIS

                                   NEW SDR

FOR

                                       DO DISPO(SDWLDA,SDC,.SDR)

                                       if SDR

                                           QUIT

 +32                           IF SDDIS

                                   DO GETDATA(SDWLDA)

                                   DO DISEND(SDWLDA,SDC)

                                   SET SDR=1

 +33                           LOCK

                           End DoDot:2

               End DoDot:1

 +34       QUIT

DISEND(SDWLDA,SDC) ;display and disposition

 +1       ;SDWLDA - IEN of 409.3

 +2        NEW DUOUT

           DO EDIT(SDWLDA,SDC,.SDWLERR)

           if $GET(DUOUT)

               QUIT

           IF SDWLERR

               QUIT

 +3        WRITE !!,"*** Patient has been removed from Wait List ***",!

 +4        KILL ^TMP($JOB,"SDWLPL",SDC)

 +5        KILL DIR,DIE,DR,DIC

 +6        QUIT

GETDATA(SDWLDA) ;retrieval data

 +1        NEW SDWLCL,SDWLDAPT,SDWLDATA,SDWLDISP,SDWLDUZ,SDWLEDT,SDWLIN,SDWLPRI,SDWLPROV,SDWLRB,SDWLSC,SDWLSP,SDWLST,SDWLTY

 +2        SET SDWLDATA=$GET(^SDWL(409.3,SDWLDA,0))

 +3        SET SDWLIN=$PIECE(SDWLDATA,U,3)

           SET SDWLCL=+$PIECE(SDWLDATA,U,4)

           SET SDWLTY=$PIECE(SDWLDATA,U,5)

           SET SDWLST=$PIECE(SDWLDATA,U,6)

 +4        SET SDWLSP=$PIECE(SDWLDATA,U,7)

           SET SDWLSS=$PIECE(SDWLDATA,U,8)

           SET SDWLSC=$PIECE(SDWLDATA,U,9)

           SET SDWLPRI=$PIECE(SDWLDATA,U,10)

           SET SDWLRB=$PIECE(SDWLDATA,U,11)

 +5        SET SDWLPROV=$PIECE(SDWLDATA,U,12)

           SET SDWLDAPT=$PIECE(SDWLDATA,U,16)

           SET SDWLST=$PIECE(SDWLDATA,U,17)

           SET SDWLDUZ=DUZ

           SET SDWLEDT=DT

 +6        SET SDWLSCL=""

           IF SDWLSC

               SET SDWLSCL=+$PIECE(^SDWL(409.32,SDWLSC,0),U,1)

 +7        IF $DATA(^SDWL(409.3,SDWLDA,"DIS"))

               SET SDWLDISP=$PIECE(^SDWL(409.3,SDWLDA,"DIS"),U,3)

 +8        QUIT

EDIT(SDWLDA,SDC,SDWLERR) ;ENTER/EDIT DISPOSITION

 +1       ;SDWLDA -IEN of selected 409.3 entry

 +2       ;SDWLERR - called by a reference

 +3       ;SDC - sequential number in ^TMP($J,"SDWLPL",SDC

 +4       ;N DIR,DR,DIE,DIC

           SET SDWLDUZ=DUZ

           SET SDWLERR=0

           SET SDWLDISP="SA"

           DO EDITSA

           QUIT

EDITSA     IF SDWLDISP="SA"

               Begin DoDot:1

 +1                IF $ORDER(^TMP($JOB,"APPT",""))=$ORDER(^TMP($JOB,"APPT",""),-1)

                       SET SDAP=$ORDER(^TMP($JOB,"APPT",""))

                       QUIT

 +2                IF $ORDER(^TMP($JOB,"APPT",""))'=$ORDER(^TMP($JOB,"APPT",""),-1)

                       DO APPTD

                       Begin DoDot:2

 +3                        WRITE !

                           KILL DIR,X

 +4                        NEW STR,SS,SDA

                           SET SDA=$ORDER(^TMP($JOB,"APPT",""),-1)

                           IF SDA=1

                               SET DIR("B")=1

 +5                        SET DIR(0)="N^1:"_SDA

                           SET DIR("A")="Select appt for Removal Reason or 'C' to Quit>"

                           SET DIR("?")="Select Appointment to close with the open EWL."

 +6                        DO ^DIR

 +7                        SET SDAP=X

                       End DoDot:2

                       IF SDAP="C"

                           WRITE !,"Disposition canceled by user",!

                           QUIT

               End DoDot:1

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

           SET DA=SDWLDA

           SET DR="21////^S X=SDWLDISP"

           DO ^DIE

 +9        SET DR="19////^S X=DT"

           DO ^DIE

 +10       SET DR="20////^S X=SDWLDUZ"

           DO ^DIE

 +11       SET DR="23////^S X=""C"""

           DO ^DIE

 +12      ;if "SA" update with appoint data

 +13      ;get appt data to file (for a particular appt #)

 +14       IF SDWLDISP="SA"

               NEW SDA

               DO DATP(SDAP,.SDA)

               Begin DoDot:1

 +15               IF $DATA(SDA)

                       SET DIE="^SDWL(409.3,"

                       SET DA=SDWLDA

                       Begin DoDot:2

 +16                       SET DR="13////"_SDA(1)_";13.1////"_DT_";13.2////"_SDA(2)_";13.3////"_SDA(15)_";13.4////"_SDA(13)_";13.5////"_SDA(14)_";13.6////"_SDA(16)_";13.8////"_SDA(3)_";13.7////"_DUZ

 +17                       DO ^DIE

                       End DoDot:2

               End DoDot:1

 +18       NEW SDWLSCL,SDWLSS,SDWLDFN

 +19       SET SDWLSCL=$PIECE($GET(^TMP($JOB,"SDWLPL",SDC)),U,9)

 +20       SET SDWLSS=$PIECE($GET(^TMP($JOB,"SDWLPL",SDC)),U,10)

 +21       IF SDWLSCL

               if $DATA(^SDWL(409.3,"SC",SDWLSCL,SDWLDA))

                   KILL ^SDWL(409.3,"SC",SDWLSCL,SDWLDA)

 +22       SET SDWLDFN=$PIECE($GET(^TMP($JOB,"APPT",1)),U,4)

 +23       IF SDWLSS

               IF SDWLDFN

                   if $DATA(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA))

                       KILL ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)

 +24       QUIT

DISPO(SDWLDA,SDC,SDR) ;

 +1       ;SDWLDA - IEN of 409.3

 +2       ;SDC - seq in ^TMP($J,"SDWLPL",SDC

 +3       ;out SDR - NON REMOVAL:

 +4       ; 1 entered

 +5       ; 0 not entered

 +6        KILL DIR,X

           SET SDR=0

 +7        SET DIR(0)="SM^1:APPOINTMENT CRITERIA NOT MET;2:PATIENT WANTS ANOTHER APPOINTMENT;3:PROVIDER WANTS ANOTHER APPOINTMENT;4:OTHER"

 +8        SET DIR("L",1)="SELECT ONE OF THE FOLLOWING REASONS FOR # "_SDC_":"

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

 +9        SET DIR("L",3)="1. APPOINTMENT CRITERIA NOT MET"

           SET DIR("L",4)="2. PATIENT WANTS ANOTHER APPOINTMENT"

 +10       SET DIR("L",5)="3. PROVIDER WANTS ANOTHER APPOINTMENT"

           SET DIR("L,6")="4. OTHER"

 +11       SET DIR("A")="Select one of the following reasons for #: "_SDC

 +12       DO ^DIR

 +13       SET X=$EXTRACT(X,1,2)

           if $EXTRACT(X,2)'="R"

               SET X=$EXTRACT(X)

 +14       SET SDWLX=$SELECT(X="a":"A",X="p":"P",X="pr":"PR",X="o":"O",X="A":"A",X="P":"P",X="PR":"PR",X="O":"O",X=1:"A",X=2:"P",X=3:"PR",X=4:"O",1:"^")

 +15       IF SDWLX="^"

               QUIT

 +16       SET SDR=1

 +17       IF SDWLX="O"

               Begin DoDot:1

 +18               SET DIR(0)="FAO^^"

                   SET DIR("A")="Comments: "

                   DO ^DIR

                   if X["^"

                       QUIT

 +19               SET SDWLCOM=X

                   SET DA=SDWLDA

                   SET DIE="^SDWL(409.3,"

                   SET DR="18.1////^S X=SDWLCOM"

                   DO ^DIE

               End DoDot:1

 +20       NEW DA

           SET DA=SDWLDA

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

           SET DR="18////^S X=SDWLX"

           DO ^DIE

 +22       SET DR="17////^S X=DUZ"

           DO ^DIE

 +23       SET DR="16////^S X=DT"

           DO ^DIE

 +24       KILL SDWLERR,DIR,DR,DIE,X,SDWLX,SDWLDSS,SDWLASK,SDWLDA,SDWLCOM

 +25       KILL ^TMP($JOB,"SDWLPL",SDC)

 +26       QUIT

HD        ;HEADER

 +1        if $DATA(IOF)

               WRITE @IOF

           WRITE !!,?80-$LENGTH("Wait List - Disposition Patient")\2,"Wait List - Disposition Patient",!!

 +2        QUIT

APPT(DFN,SD,SC) ;create appt TMP

 +1       ;SD - appt date/time

 +2       ;SC - clinic IEN

 +3        NEW SDARR,SCNT

 +4        SET SDDIV=""

 +5        SET SDARR(1)=SD_";"_SD

 +6        SET SDARR(2)=SC

 +7        SET SDARR(4)=DFN

 +8        SET SDARR("FLDS")="1;2;3;4;10;13;14;17"

 +9        NEW SAPP

           SET SAPP=$$SDAPI^SDAMA301(.SDARR)

           Begin DoDot:1

 +10           NEW SDINST,SDFAC,SDINSTE

 +11           if '$DATA(^TMP($JOB,"SDAMA301",DFN))

                   QUIT

 +12           SET SCNT=$ORDER(^TMP($JOB,"APPT",""),-1)+1

 +13           SET ^TMP($JOB,"APPT",SCNT)=^TMP($JOB,"SDAMA301",DFN,SC,SD)

 +14           NEW SDCLIN

               SET SDCLIN=$$CLIN^SDWLBACC(SC)

               SET SDINST=$PIECE(SDCLIN,U)

               SET SDFAC=$PIECE(SDCLIN,U,2)

               SET SDINSTE=$PIECE(SDCLIN,U,3)

 +15           SET $PIECE(^TMP($JOB,"APPT",SCNT),"^",15)=SDINST_";"_SDINSTE

 +16           SET $PIECE(^TMP($JOB,"APPT",SCNT),"^",16)=SDFAC

 +17           KILL ^TMP($JOB,"SDAMA301",DFN,SC,SD)

           End DoDot:1

 +18       QUIT

APPTD     ;display appt

 +1       ;from ^TMP($J,"APPT")

 +2        NEW STR,SCNT

 +3        if '$DATA(^TMP($JOB,"APPT"))

               QUIT

 +4        SET SCNT=""

FOR

               SET SCNT=$ORDER(^TMP($JOB,"APPT",SCNT))

               if SCNT=""

                   QUIT

               Begin DoDot:1

 +5                SET STR=^TMP($JOB,"APPT",SCNT)

 +6                NEW ZZ

                   FOR ZZ=2,3,4,10,15

                       SET SDD(ZZ)=$PIECE($PIECE(STR,"^",ZZ),";",2)

 +7       ; date conv

                   NEW SD

                   SET SD=$PIECE(STR,U)

                   Begin DoDot:2

 +8                    IF SDD(3)="SCHEDULED/KEPT"

                           SET SDD(3)=";"_$SELECT(SD<DT:"KEPT",1:"SCHEDULED")

                   End DoDot:2

                   SET Y=SD

                   DO D^DIQ

                   SET SDD(1)=Y

 +9                SET SDD(16)=$PIECE(STR,U,16)

 +10               NEW CP,ZZ

                   FOR ZZ=13,14

                       SET CP(ZZ)=$PIECE($PIECE(STR,U,ZZ),";")

                       Begin DoDot:2

 +11                       SET SDD(ZZ)=""

 +12      ; stop code desc

                           IF CP(ZZ)>0

                               SET SDD(ZZ)=$$GET1^DIQ(40.7,CP(ZZ)_",",.01,"I")

                       End DoDot:2

 +13      ;DISPLAY

 +14               IF SCNT=1

                       DO DPH(SCNT,.SDD)

 +15               DO DPHD(SCNT,.SDD)

               End DoDot:1

 +16       WRITE !

 +17       QUIT

DATP(SCNT,SDA) ;

 +1       ;SDA - to return APPT array

 +2        SET STR=^TMP($JOB,"APPT",SCNT)

 +3        SET SDA(1)=$PIECE(STR,U)

 +4        NEW ZZ

           FOR ZZ=2,3,10,13,14,15

               SET SDA(ZZ)=$PIECE($PIECE(STR,"^",ZZ),";",1)

 +5       ;station

           SET SDA(16)=$PIECE(STR,"^",16)

 +6        QUIT

DPH(SCNT,SDD) ;display appt header

 +1        WRITE !!,"Appointment(s) for: "_SDD(4)

           WRITE !!?4,"Specialty: "_SDD(13),?60,"Station: ",SDD(16),!

 +2        WRITE !?3,"Appt Date/Time",?23,"Clinic",?48,"Status",?60,"Institution",!

           NEW SDL

           SET $PIECE(SDL,"-",79)=""

           WRITE SDL,!

 +3        QUIT

DPHD(SCNT,SDD) ;

 +1        WRITE !,SCNT,?3,SDD(1),?23,$EXTRACT(SDD(2),1,23),?48,$EXTRACT(SDD(10),1,10),?60,SDD(15)

 +2        QUIT

SDWLEVAL.m