SDWLDISP ;;IOFO BAY PINES/TEH - WAIT LIST - DISPOSITION WAIT LIST ENTRY;06/12/2002 ; 20 Aug 2002 2:10 PM ; Compiled January 26, 2007 10:21:25
;;5.3;scheduling;**263,273,427,454,446**;AUG 13 1993;Build 77
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 11/19/2002 SD*5.3*273 EN1+4 CHECK FOR "^"
; 11/19/2002 SD*5.3*273 REMOVED DIC("S") SCREEN FROM PAT
; 08/07/2008 SD*5.3*446 check out EWL if DFN defined
; 04/12/2006 SD*5.3*446 Inter-facility transfer/New Disposition type: CL
;
;
;
EN ;
S SDWLERR=0
I $D(SDWLLIST),SDWLLIST D
.I $G(DFN)'>0 S SDWLERR=1 Q
.I $D(DFN),'$D(^SDWL(409.3,"B",DFN)) D HD,1^VADPT,DEM^VADPT W !,VADM(1),?40,VA("PID"),*7,!,"This Patient has NO entries on the Electronic Wait List." S DIR(0)="E" D ^DIR S DUOUT=1 Q
I $D(DUOUT) Q
I 'SDWLERR,$D(SDWLLIST),SDWLLIST D HD S SDWLDFN=DFN K DIR,DIC,DR,DIE,VADM D 1^VADPT,DEM^VADPT W !,VADM(1),?40,VA("PID") S (SDWLBDT,SDWLEDT)="" D DIS G EN1
K DIR,DIC,DR,DIE
;OPTION HEADER
;
S SDWLOP=" - Disposition Patient" D HD
;
;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0).
;
D PAT G END:'$D(SDWLDFN),END:SDWLDFN<0,END:SDWLDFN=""
;
;DISPLAY PATIENT DATA FROM ^SDWL(409.3,IEN,0).
;
D DIS
;PROMPT USER FOR RECORD FOR DISPOSITIONING.
;
EN1 K DIR,DIC,DIE,DR,X,Y,SDWLERR S SDWLPS=$S(SDWLCN>1:1,SDWLCN=1:2,1:0),SDWLERR=0
I SDWLPS=0 W !!,"Patient has no Wait List Entries to Disposition." S DIR(0)="E" D ^DIR G END
I SDWLPS=1 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1-"_SDWLCN_") or '^' to Quit? "
I SDWLPS=2 S DIR(0)="FOA^^" S DIR("A")="Disposition This 'ENTRY' or '^' to Quit? Yes // "
W ! D ^DIR G END:X["^" S SDWLY=Y W !
I SDWLPS=1 D
.S SDWLERR=$S(X?1N.N:0,X?1"N".E:1,X?1"n".E:1,X="":1,X?1"Y".E:0,X?1"y".E:0,$D(DUOUT):1,X["^":1,1:2)
I $D(SDWLERR),SDWLERR=2 W *7," Invalid Entry" G EN1
I SDWLPS=2 D
.S SDWLERR=$S(X="":0,X?1"Y".E:0,X?1"y":0,X?1"N".E:1,X?1"n".E:1,X["^":1,1:2)
I SDWLERR=2 W *7," Invalid Entry" G EN1
G END:SDWLERR
I SDWLPS=2,'SDWLY S SDWLY=1
S SDWLERR=0 I SDWLY?1N.N D G EN1:SDWLERR
.K DIR,DIC,DR
.;
.;CHECK FOR VALID ENTRY
.;
.I '$D(^TMP("SDWLD",$J,SDWLDFN,+SDWLY)) W " Invalid Entry " S SDWLERR=1 Q
.S SDWLDA=$P($G(^TMP("SDWLD",$J,SDWLDFN,+SDWLY)),"~",2)
.;
.;LOCK DATA FILE
.;
.L ^SDWL(409.3,SDWLDA):5 I '$T W !,"Another User is Editing this Entry. Try Later." S DUOUT=1
I $D(DUOUT) G END
;
;GET PATIENT DATA FROM ^SDWL(409.3,IEN,0).
;
D GETDATA
;
;ENTER DISPOSITION
;
D EDIT G END:$D(DUOUT) I $D(SDWLERR) G END:SDWLERR
W !,"*** Patient has been removed from Wait List. ***"
K DIR,DIE,DR,DIC
S DIR(0)="E" D ^DIR I $D(DUOUT) G END
D END G EN
;
Q
PAT ;PATIENT LOOK-UP
;
S DIC(0)="EMNAQ",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2) G PAT1:DFN<0
G PAT1:DFN=""
S SDWLNAM=$$GET1^DIQ(2,DFN_",",.01)
S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" W !!,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" ;SD*5.3*454 allow user to disposition deceased patient
D 1^VADPT
PAT1 Q
;
DIS ;DISPLAY DATA FOR PATIENT
;
S SDWLDISC="",SDWLCN=0,SDWLHDR="Wait List Disposition"
D EN^SDWLD(SDWLDFN,VA("PID"),VADM(1))
K VADM,VAIN,VA,SDWLDISC
Q
GETDATA ;PATIENT DATA RETRIEVAL
;
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)
Q
EDIT ;ENTER/EDIT DISPOSITION
;
S SDWLDUZ=DUZ,SDWLERR=0 N DIR,DR,DIE,DIC,DA
I $D(SDWLDISP) S DIR("B")=$$EXTERNAL^DILFD(409.3,21,,SDWLDISP)
S DIR(0)="SO^D:DEATH;NC:REMOVED/NON-VA CARE;SA:REMOVED/SCHEDULED-ASSIGNED;CC:REMOVED/VA CONTRACT CARE;NN:REMOVED/NO LONGER NECESSARY;ER:ENTERED IN ERROR;CL:CLINIC CHANGE^"
S DIR("L",1)="Disposition Reason:",DIR("L",2)="",DIR("L",3)="D DEATH",DIR("L",4)="NC REMOVED/NON-VA CARE",DIR("L",5)="SA REMOVED/SCHEDULED-ASSIGNED"
S DIR("L",6)="CC REMOVED/VA CONTRACT CARE",DIR("L",7)="NN REMOVED/NO LONGER NECESSARY",DIR("L")="ER ENTERED IN ERROR"
S:SDWLTY=4 DIR("L",8)="CL CLINIC CHANGE"
D ^DIR
I X="" S DUOUT=1 Q
I X="^" S DUOUT=1 Q
;S SDWLDISP=$S(X["D":"D",X["d":"D",X["NC":"NC",X["nc":"NC",X["SA":"SA",X["sa":"SA",X["CC":"CC",X["cc":"CC",X["NN":"NN",X["nn":"NN",X["ER":"ER",X["er":"ER",1:0)
;I SDWLDISP=0 S SDWLERR=1
S SDWLDISP=$TR(X,"acdelnrst","ACDELNRST") S:"^D^NC^SA^CC^NN^ER^TR^"_$S(SDWLTY=4:"CL^",1:"")'[("^"_SDWLDISP_"^") SDWLERR=1
I SDWLERR W *7,"Invalid Entry" G EDIT
I SDWLDISP="SA" I "3,4"[SDWLTY D PKAPP(SDWLDA,SDWLTY,.SDWLDATA) Q ; QUIT OR NOT?
I SDWLDISP="CL" S SDWLERR=$$EN^SDWLE7 Q:SDWLERR ; OG ; 446
S DIE("NO^")="NO EDITING"
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
I SDWLSCL K:$D(^SDWL(409.3,"SC",SDWLSCL,SDWLDA)) ^SDWL(409.3,"SC",SDWLSCL,SDWLDA)
I SDWLSS K:$D(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)) ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)
; OG ; SD*5.3*446 Inter-facility transfer.
D DIS^SDWLE6(SDWLDA)
Q
PKAPP(SDWLDA,SDWLTY,SDWLDATA) ;identify appointemnt to close with
;SDWLDA -ien OF 409.3 to be closed
;SDWLTY - type of EWL entry
;SDWLDATA - 0 node of SDWLDA
N SDCL,SDSP,SDORG,SDPCL,SDPSP S (SDCL,SDSP)="" N PROC S PROC=1
S SDPCL=$$GET1^DIQ(409.3,SDWLDA_",",8,"I"),SDPSP=$$GET1^DIQ(409.3,SDWLDA_",",7,"I")
I SDWLTY=4 S SDCL=$$GET1^DIQ(409.32,SDPCL_",",.01,"I")
I SDWLTY=3 S SDSP=$$GET1^DIQ(409.31,SDPSP_",",.01,"I")
S SDORG=$$GET1^DIQ(409.3,SDWLDA_",",1,"I")
;display app/encounters
N SDDS,SDAP S SDDS=$$CHKENC^SDWLQSC1(DFN,SDORG,SDCL,SDSP,PROC)
I SDWLDISP="SA" D
.I $O(^TMP($J,"APPT",""))=$O(^TMP($J,"APPT",""),-1) S SDAP=$O(^TMP($J,"APPT","")) D Q
..Q:SDAP=""
..D APPTD^SDWLEVAL D SING(SDWLDA,SDWLTY,SDWLDATA)
.I $O(^TMP($J,"APPT",""))'=$O(^TMP($J,"APPT",""),-1) D APPTD^SDWLEVAL D I SDAP="^" 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 '^' to Quit>",DIR("?")="Select Appointment to close with the open EWL."
..D ^DIR
..S SDAP=X Q:X="^"!'X D SING(SDWLDA,SDWLTY,SDWLDATA)
Q:SDAP="^" ;should we allow to quit or to proceed without filing an appointment?
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
Q
SING(SDWLDA,SDWLTY,SDWLDATA) ;called for filing with appointment if any
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^SDWLEVAL(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(SDWLDATA,U,9)
;S SDWLSCL=$P($G(^TMP($J,"SDWLPL",SDC)),U,9)
S SDWLSS=$P(SDWLDATA,U,8)
;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)
Q
HD ;HEADER
;
W:$D(IOF) @IOF W !!,?80-$L("Wait List - Disposition Patient")\2,"Wait List - Disposition Patient",!!
;
END ;QUIT OPTION
K DIC,DIR,DR,DIE,SDWLDFN,DUOUT,SDWLSCL
K SDWLCL,SDWSLCN,SDWLDA,SDWLDAPT,SDWLDATA,SDWLDFN,SDWLDISP,SDWLDUZ,SDWLEDT,SDWLERR,SDWLIN,SDWLNAM,SDWLOP,SDWLPRI
K SDWLPROV,SDWLPS,SDWLRB,SDWLSC,SDWLSP,SDWLSS,SDWLST,SDWLTY,SDWLY,X,Y,SDWLHDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLDISP 8557 printed Dec 13, 2024@03:02:21 Page 2
SDWLDISP ;;IOFO BAY PINES/TEH - WAIT LIST - DISPOSITION WAIT LIST ENTRY;06/12/2002 ; 20 Aug 2002 2:10 PM ; Compiled January 26, 2007 10:21:25
+1 ;;5.3;scheduling;**263,273,427,454,446**;AUG 13 1993;Build 77
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ; 11/19/2002 SD*5.3*273 EN1+4 CHECK FOR "^"
+10 ; 11/19/2002 SD*5.3*273 REMOVED DIC("S") SCREEN FROM PAT
+11 ; 08/07/2008 SD*5.3*446 check out EWL if DFN defined
+12 ; 04/12/2006 SD*5.3*446 Inter-facility transfer/New Disposition type: CL
+13 ;
+14 ;
+15 ;
EN ;
+1 SET SDWLERR=0
+2 IF $DATA(SDWLLIST)
IF SDWLLIST
Begin DoDot:1
+3 IF $GET(DFN)'>0
SET SDWLERR=1
QUIT
+4 IF $DATA(DFN)
IF '$DATA(^SDWL(409.3,"B",DFN))
DO HD
DO 1^VADPT
DO DEM^VADPT
WRITE !,VADM(1),?40,VA("PID"),*7,!,"This Patient has NO entries on the Electronic Wait List."
SET DIR(0)="E"
DO ^DIR
SET DUOUT=1
QUIT
End DoDot:1
+5 IF $DATA(DUOUT)
QUIT
+6 IF 'SDWLERR
IF $DATA(SDWLLIST)
IF SDWLLIST
DO HD
SET SDWLDFN=DFN
KILL DIR,DIC,DR,DIE,VADM
DO 1^VADPT
DO DEM^VADPT
WRITE !,VADM(1),?40,VA("PID")
SET (SDWLBDT,SDWLEDT)=""
DO DIS
GOTO EN1
+7 KILL DIR,DIC,DR,DIE
+8 ;OPTION HEADER
+9 ;
+10 SET SDWLOP=" - Disposition Patient"
DO HD
+11 ;
+12 ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0).
+13 ;
+14 DO PAT
if '$DATA(SDWLDFN)
GOTO END
if SDWLDFN<0
GOTO END
if SDWLDFN=""
GOTO END
+15 ;
+16 ;DISPLAY PATIENT DATA FROM ^SDWL(409.3,IEN,0).
+17 ;
+18 DO DIS
+19 ;PROMPT USER FOR RECORD FOR DISPOSITIONING.
+20 ;
EN1 KILL DIR,DIC,DIE,DR,X,Y,SDWLERR
SET SDWLPS=$SELECT(SDWLCN>1:1,SDWLCN=1:2,1:0)
SET SDWLERR=0
+1 IF SDWLPS=0
WRITE !!,"Patient has no Wait List Entries to Disposition."
SET DIR(0)="E"
DO ^DIR
GOTO END
+2 IF SDWLPS=1
SET DIR(0)="FOA^^"
SET DIR("A")="Select Wait List (1-"_SDWLCN_") or '^' to Quit? "
+3 IF SDWLPS=2
SET DIR(0)="FOA^^"
SET DIR("A")="Disposition This 'ENTRY' or '^' to Quit? Yes // "
+4 WRITE !
DO ^DIR
if X["^"
GOTO END
SET SDWLY=Y
WRITE !
+5 IF SDWLPS=1
Begin DoDot:1
+6 SET SDWLERR=$SELECT(X?1N.N:0,X?1"N".E:1,X?1"n".E:1,X="":1,X?1"Y".E:0,X?1"y".E:0,$DATA(DUOUT):1,X["^":1,1:2)
End DoDot:1
+7 IF $DATA(SDWLERR)
IF SDWLERR=2
WRITE *7," Invalid Entry"
GOTO EN1
+8 IF SDWLPS=2
Begin DoDot:1
+9 SET SDWLERR=$SELECT(X="":0,X?1"Y".E:0,X?1"y":0,X?1"N".E:1,X?1"n".E:1,X["^":1,1:2)
End DoDot:1
+10 IF SDWLERR=2
WRITE *7," Invalid Entry"
GOTO EN1
+11 if SDWLERR
GOTO END
+12 IF SDWLPS=2
IF 'SDWLY
SET SDWLY=1
+13 SET SDWLERR=0
IF SDWLY?1N.N
Begin DoDot:1
+14 KILL DIR,DIC,DR
+15 ;
+16 ;CHECK FOR VALID ENTRY
+17 ;
+18 IF '$DATA(^TMP("SDWLD",$JOB,SDWLDFN,+SDWLY))
WRITE " Invalid Entry "
SET SDWLERR=1
QUIT
+19 SET SDWLDA=$PIECE($GET(^TMP("SDWLD",$JOB,SDWLDFN,+SDWLY)),"~",2)
+20 ;
+21 ;LOCK DATA FILE
+22 ;
+23 LOCK ^SDWL(409.3,SDWLDA):5
IF '$TEST
WRITE !,"Another User is Editing this Entry. Try Later."
SET DUOUT=1
End DoDot:1
if SDWLERR
GOTO EN1
+24 IF $DATA(DUOUT)
GOTO END
+25 ;
+26 ;GET PATIENT DATA FROM ^SDWL(409.3,IEN,0).
+27 ;
+28 DO GETDATA
+29 ;
+30 ;ENTER DISPOSITION
+31 ;
+32 DO EDIT
if $DATA(DUOUT)
GOTO END
IF $DATA(SDWLERR)
if SDWLERR
GOTO END
+33 WRITE !,"*** Patient has been removed from Wait List. ***"
+34 KILL DIR,DIE,DR,DIC
+35 SET DIR(0)="E"
DO ^DIR
IF $DATA(DUOUT)
GOTO END
+36 DO END
GOTO EN
+37 ;
+38 QUIT
PAT ;PATIENT LOOK-UP
+1 ;
+2 SET DIC(0)="EMNAQ"
SET DIC=409.3
DO ^DIC
SET (SDWLDFN,DFN)=$PIECE(Y,U,2)
if DFN<0
GOTO PAT1
+3 if DFN=""
GOTO PAT1
+4 SET SDWLNAM=$$GET1^DIQ(2,DFN_",",.01)
+5 ;SD*5.3*454 allow user to disposition deceased patient
SET X=$$GET1^DIQ(2,DFN_",",".351")
IF X'=""
WRITE !!,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED"
+6 DO 1^VADPT
PAT1 QUIT
+1 ;
DIS ;DISPLAY DATA FOR PATIENT
+1 ;
+2 SET SDWLDISC=""
SET SDWLCN=0
SET SDWLHDR="Wait List Disposition"
+3 DO EN^SDWLD(SDWLDFN,VA("PID"),VADM(1))
+4 KILL VADM,VAIN,VA,SDWLDISC
+5 QUIT
GETDATA ;PATIENT DATA RETRIEVAL
+1 ;
+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 ;ENTER/EDIT DISPOSITION
+1 ;
+2 SET SDWLDUZ=DUZ
SET SDWLERR=0
NEW DIR,DR,DIE,DIC,DA
+3 IF $DATA(SDWLDISP)
SET DIR("B")=$$EXTERNAL^DILFD(409.3,21,,SDWLDISP)
+4 SET DIR(0)="SO^D:DEATH;NC:REMOVED/NON-VA CARE;SA:REMOVED/SCHEDULED-ASSIGNED;CC:REMOVED/VA CONTRACT CARE;NN:REMOVED/NO LONGER NECESSARY;ER:ENTERED IN ERROR;CL:CLINIC CHANGE^"
+5 SET DIR("L",1)="Disposition Reason:"
SET DIR("L",2)=""
SET DIR("L",3)="D DEATH"
SET DIR("L",4)="NC REMOVED/NON-VA CARE"
SET DIR("L",5)="SA REMOVED/SCHEDULED-ASSIGNED"
+6 SET DIR("L",6)="CC REMOVED/VA CONTRACT CARE"
SET DIR("L",7)="NN REMOVED/NO LONGER NECESSARY"
SET DIR("L")="ER ENTERED IN ERROR"
+7 if SDWLTY=4
SET DIR("L",8)="CL CLINIC CHANGE"
+8 DO ^DIR
+9 IF X=""
SET DUOUT=1
QUIT
+10 IF X="^"
SET DUOUT=1
QUIT
+11 ;S SDWLDISP=$S(X["D":"D",X["d":"D",X["NC":"NC",X["nc":"NC",X["SA":"SA",X["sa":"SA",X["CC":"CC",X["cc":"CC",X["NN":"NN",X["nn":"NN",X["ER":"ER",X["er":"ER",1:0)
+12 ;I SDWLDISP=0 S SDWLERR=1
+13 SET SDWLDISP=$TRANSLATE(X,"acdelnrst","ACDELNRST")
if "^D^NC^SA^CC^NN^ER^TR^"_$SELECT(SDWLTY=4
SET SDWLERR=1
+14 IF SDWLERR
WRITE *7,"Invalid Entry"
GOTO EDIT
+15 ; QUIT OR NOT?
IF SDWLDISP="SA"
IF "3,4"[SDWLTY
DO PKAPP(SDWLDA,SDWLTY,.SDWLDATA)
QUIT
+16 ; OG ; 446
IF SDWLDISP="CL"
SET SDWLERR=$$EN^SDWLE7
if SDWLERR
QUIT
+17 SET DIE("NO^")="NO EDITING"
+18 SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
SET DR="21////^S X=SDWLDISP"
DO ^DIE
+19 SET DR="19////^S X=DT"
DO ^DIE
+20 SET DR="20////^S X=SDWLDUZ"
DO ^DIE
+21 SET DR="23////^S X=""C"""
DO ^DIE
+22 IF SDWLSCL
if $DATA(^SDWL(409.3,"SC",SDWLSCL,SDWLDA))
KILL ^SDWL(409.3,"SC",SDWLSCL,SDWLDA)
+23 IF SDWLSS
if $DATA(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA))
KILL ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)
+24 ; OG ; SD*5.3*446 Inter-facility transfer.
+25 DO DIS^SDWLE6(SDWLDA)
+26 QUIT
PKAPP(SDWLDA,SDWLTY,SDWLDATA) ;identify appointemnt to close with
+1 ;SDWLDA -ien OF 409.3 to be closed
+2 ;SDWLTY - type of EWL entry
+3 ;SDWLDATA - 0 node of SDWLDA
+4 NEW SDCL,SDSP,SDORG,SDPCL,SDPSP
SET (SDCL,SDSP)=""
NEW PROC
SET PROC=1
+5 SET SDPCL=$$GET1^DIQ(409.3,SDWLDA_",",8,"I")
SET SDPSP=$$GET1^DIQ(409.3,SDWLDA_",",7,"I")
+6 IF SDWLTY=4
SET SDCL=$$GET1^DIQ(409.32,SDPCL_",",.01,"I")
+7 IF SDWLTY=3
SET SDSP=$$GET1^DIQ(409.31,SDPSP_",",.01,"I")
+8 SET SDORG=$$GET1^DIQ(409.3,SDWLDA_",",1,"I")
+9 ;display app/encounters
+10 NEW SDDS,SDAP
SET SDDS=$$CHKENC^SDWLQSC1(DFN,SDORG,SDCL,SDSP,PROC)
+11 IF SDWLDISP="SA"
Begin DoDot:1
+12 IF $ORDER(^TMP($JOB,"APPT",""))=$ORDER(^TMP($JOB,"APPT",""),-1)
SET SDAP=$ORDER(^TMP($JOB,"APPT",""))
Begin DoDot:2
+13 if SDAP=""
QUIT
+14 DO APPTD^SDWLEVAL
DO SING(SDWLDA,SDWLTY,SDWLDATA)
End DoDot:2
QUIT
+15 IF $ORDER(^TMP($JOB,"APPT",""))'=$ORDER(^TMP($JOB,"APPT",""),-1)
DO APPTD^SDWLEVAL
Begin DoDot:2
+16 WRITE !
KILL DIR,X
+17 NEW STR,SS,SDA
SET SDA=$ORDER(^TMP($JOB,"APPT",""),-1)
IF SDA=1
SET DIR("B")=1
+18 SET DIR(0)="N^1:"_SDA
SET DIR("A")="Select appt for Removal Reason or '^' to Quit>"
SET DIR("?")="Select Appointment to close with the open EWL."
+19 DO ^DIR
+20 SET SDAP=X
if X="^"!'X
QUIT
DO SING(SDWLDA,SDWLTY,SDWLDATA)
End DoDot:2
IF SDAP="^"
WRITE !,"Disposition canceled by user",!
QUIT
End DoDot:1
+21 ;should we allow to quit or to proceed without filing an appointment?
if SDAP="^"
QUIT
+22 SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
SET DR="21////^S X=SDWLDISP"
DO ^DIE
+23 SET DR="19////^S X=DT"
DO ^DIE
+24 SET DR="20////^S X=SDWLDUZ"
DO ^DIE
+25 SET DR="23////^S X=""C"""
DO ^DIE
+26 QUIT
SING(SDWLDA,SDWLTY,SDWLDATA) ;called for filing with appointment if any
+1 SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
SET DR="21////^S X=SDWLDISP"
DO ^DIE
+2 SET DR="19////^S X=DT"
DO ^DIE
+3 SET DR="20////^S X=SDWLDUZ"
DO ^DIE
+4 SET DR="23////^S X=""C"""
DO ^DIE
+5 ;if "SA" update with appoint data
+6 ;get appt data to file (for a particular appt #)
+7 IF SDWLDISP="SA"
NEW SDA
DO DATP^SDWLEVAL(SDAP,.SDA)
Begin DoDot:1
+8 IF $DATA(SDA)
SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
Begin DoDot:2
+9 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
+10 DO ^DIE
End DoDot:2
End DoDot:1
+11 NEW SDWLSCL,SDWLSS,SDWLDFN
+12 SET SDWLSCL=$PIECE(SDWLDATA,U,9)
+13 ;S SDWLSCL=$P($G(^TMP($J,"SDWLPL",SDC)),U,9)
+14 SET SDWLSS=$PIECE(SDWLDATA,U,8)
+15 ;S SDWLSS=$P($G(^TMP($J,"SDWLPL",SDC)),U,10)
+16 IF SDWLSCL
if $DATA(^SDWL(409.3,"SC",SDWLSCL,SDWLDA))
KILL ^SDWL(409.3,"SC",SDWLSCL,SDWLDA)
+17 SET SDWLDFN=$PIECE($GET(^TMP($JOB,"APPT",1)),U,4)
+18 IF SDWLSS
IF SDWLDFN
if $DATA(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA))
KILL ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)
+19 QUIT
HD ;HEADER
+1 ;
+2 if $DATA(IOF)
WRITE @IOF
WRITE !!,?80-$LENGTH("Wait List - Disposition Patient")\2,"Wait List - Disposition Patient",!!
+3 ;
END ;QUIT OPTION
+1 KILL DIC,DIR,DR,DIE,SDWLDFN,DUOUT,SDWLSCL
+2 KILL SDWLCL,SDWSLCN,SDWLDA,SDWLDAPT,SDWLDATA,SDWLDFN,SDWLDISP,SDWLDUZ,SDWLEDT,SDWLERR,SDWLIN,SDWLNAM,SDWLOP,SDWLPRI
+3 KILL SDWLPROV,SDWLPS,SDWLRB,SDWLSC,SDWLSP,SDWLSS,SDWLST,SDWLTY,SDWLY,X,Y,SDWLHDR
+4 QUIT
