- 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 Feb 19, 2025@00:28:51 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