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
Q
;
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
Q
;
;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
Q
;
DUP ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLE110 5032 printed Apr 09, 2024@22:01:24 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
