SDWLR ;;IOFO BAY PINES/TEH - WAIT LIST - SDM1 DISPOSITION;06/12/2002 ; 20 Aug 2002 2:10 PM
;;5.3;scheduling;**263,1015**;AUG 13 1993;Build 21
;
;
;
;
;
;
;
EN ;
I '$D(^SDWL(409.3,"B",DFN)) Q
N DA,SDWLCOM
S SDWLERR=0,SDWLCN=0
D SB0 G END:'SDWLASK
W !!,"THIS PATIENT IS CURRENTLY ON THE WAITING LIST FOR THIS CLINIC/SPECIALTY"
S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLIN=$P(X,U,3),SDWLCL=$P(X,U,4),SDWLTY=$P(X,U,5),SDWLPRI=$P(X,U,11)
S SDWLDSP=$P(X,U,17)
S SDWLDT=$P(X,U,16),SDWLTYN=$$EXTERNAL^DILFD(409.3,4,,SDWLTY),SDWLPRIN=$$EXTERNAL^DILFD(409.3,10,,SDWLPRI)
S SDWLSTO=$P(X,U,22),SDWLSPO=$P(X,U,23),SDWLSSO=$P(X,U,24),SDWLSCO=$P(X,U,25)
S SDWLST=$P(X,U,6),SDWLSP=$P(X,U,7),SDWLSS=$P(X,U,8),SDWLSC=$P(X,U,9),SDWLWR="" D
.I SDWLST'="" S SDWLWR=$$EXTERNAL^DILFD(409.3,5,,SDWLST)
.I SDWLSTO["Y" S SDWLWR="OPEN"
.I SDWLSP'="" S SDWLWR=$$EXTERNAL^DILFD(409.3,6,,SDWLSP)
.I SDWLSPO["Y" S SDWLWR="OPEN"
.I SDWLSS'="" S SDWLWR=$$EXTERNAL^DILFD(409.3,7,,SDWLSS)
.I SDWLSSO["Y" S SDWLWR="OPEN"
.I SDWLSC'="" S SDWLWR=$$EXTERNAL^DILFD(409.3,8,,SDWLSC)
.I SDWLSCO["^" S SDWLWR="OPEN"
S YY=$E(SDWLDT,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDT,4,5),DD=$E(SDWLDT,6,7),SDWLDTP=MM_DD_YY
S SDWLCLN="" I $D(^SC(+SDWLCL,0)) S SDWLCLN=$$GET1^DIQ(44,SDWLCL_",",1,,)
S SDWLINN=$E($P($G(^DIC(4,+SDWLIN,0)),U,1),1,8)
S SDWLDIS=$P($G(^SDWL(409.3,SDWLDA,"DIS")),U,3),SDWLDISN=$$EXTERNAL^DILFD(409.3,21,,SDWLDIS)
W !,$E(SDWLTYN,1,14),?22,SDWLPRI,?25,$E(SDWLWR,1,19),?51,$E(SDWLINN,1,14) W:$D(SDWLDISC) ?67,SDWLDSP
W ?73,SDWLDTP
W !,"DO YOU WISH TO REMOVE FROM LIST " S %=1
D YN^DICN I %=1 D SB1 Q
K DIR,X
S DIR(0)="S0^1:APPOINTMENT CRITERIA NOT MEET;2:PATIENT WANT ANOTHER APPOINTMENT;3:PROVIDER WANTS ANOTHER APPOINTMENT;4:OTHER"
S DIR("L",1)="SELECT ONE OF THE FOLLOWING REASONS:",DIR("L",2)=""
S DIR("L",3)="1. APPOINTMENT CRITERIA NOT MEET",DIR("L",4)="2. PATIENT WANTS ANOTHER APPOINTMENT"
S DIR("L",5)="3. PROVIDER WANTS ANOTHER APPOINTMENT",DIR("L")="4. OTHER"
D ^DIR
S SDWLX=$S(X="O":X="0",X="o":X=4,X="pr":X="PR",X="p":"P",X="a":"A",X=1:"A",X=2:"P",X=3:"PR",X=4:"O",X["A":"A",X="P":"P",X["^":"^",X="":"")
G EN:SDWLX["^",END:SDWLX=""
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
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
Q
SB0 ;-Screen Appointment for valid clinic and/or service/specialty.
S SDWLDSS=+$P(^SC(+SC,0),U,7),SDWLASK=0
S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",DFN,SDWLDA)) Q:SDWLDA="" S SDWLDA(SDWLDA)=""
I $D(^SDWL(409.3,"SC",+SC)) S SDWLDA="" F S SDWLDA=$O(SDWLDA(SDWLDA)) Q:SDWLDA="" I $D(^SDWL(409.3,"SC",+SC,SDWLDA)) S SDWLASK=1,SDWLDAV=SDWLDA Q
I $D(^SDWL(409.3,"SS",DFN,SDWLDSS)) S SDWLDA="" F S SDWLDA=$O(SDWLDA(SDWLDA)) Q:SDWLDA="" I $D(^SDWL(409.3,"SS",DFN,SDWLDSS,SDWLDA)) S SDWLASK=2,SDWLDAV=SDWLDA
I $D(SDWLDAV) S SDWLDA=SDWLDAV K SDWLDAV
Q
SB1 ;-wants to remove patient from the wait list. Set Disposition
I $D(SDWLDA),'$D(^SDWL(409.3,+SDWLDA)),SDWLERR=1 Q
S DA=SDWLDA
S DIE="^SDWL(409.3,",DR="19////^S X=DT" D ^DIE
S DR="20////^S X=DUZ" D ^DIE
S DR="21////^S X=""SA""" D ^DIE
S DR="23////^S X=""C""" D ^DIE
I SDWLASK=1 K ^SDWL(409.3,"SC",SC,SDWLDA)
I SDWLASK=2 K ^SDWL(409.3,"SS",DFN,SDWLDSS,SDWLDA)
END K SDWLDT,SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLPRIN,SDWLTYN,SDWLST,SDWLSP,SDWLCLN,SDWLDTP,SDWLINN,SDWLDISN
K SDWLPRI,SDWLWR,SDWLDA,SDWLSC,SDWLSS
Q
SDWLR ;;IOFO BAY PINES/TEH - WAIT LIST - SDM1 DISPOSITION;06/12/2002 ; 20 Aug 2002 2:10 PM
+1 ;;5.3;scheduling;**263,1015**;AUG 13 1993;Build 21
+2 ;
+3 ;
+4 ;
+5 ;
+6 ;
+7 ;
+8 ;
EN ;
+1 IF '$DATA(^SDWL(409.3,"B",DFN))
QUIT
+2 NEW DA,SDWLCOM
+3 SET SDWLERR=0
SET SDWLCN=0
+4 DO SB0
IF 'SDWLASK
GOTO END
+5 WRITE !!,"THIS PATIENT IS CURRENTLY ON THE WAITING LIST FOR THIS CLINIC/SPECIALTY"
+6 SET X=$GET(^SDWL(409.3,SDWLDA,0))
SET SDWLIN=$PIECE(X,U,3)
SET SDWLCL=$PIECE(X,U,4)
SET SDWLTY=$PIECE(X,U,5)
SET SDWLPRI=$PIECE(X,U,11)
+7 SET SDWLDSP=$PIECE(X,U,17)
+8 SET SDWLDT=$PIECE(X,U,16)
SET SDWLTYN=$$EXTERNAL^DILFD(409.3,4,,SDWLTY)
SET SDWLPRIN=$$EXTERNAL^DILFD(409.3,10,,SDWLPRI)
+9 SET SDWLSTO=$PIECE(X,U,22)
SET SDWLSPO=$PIECE(X,U,23)
SET SDWLSSO=$PIECE(X,U,24)
SET SDWLSCO=$PIECE(X,U,25)
+10 SET SDWLST=$PIECE(X,U,6)
SET SDWLSP=$PIECE(X,U,7)
SET SDWLSS=$PIECE(X,U,8)
SET SDWLSC=$PIECE(X,U,9)
SET SDWLWR=""
Begin DoDot:1
+11 IF SDWLST'=""
SET SDWLWR=$$EXTERNAL^DILFD(409.3,5,,SDWLST)
+12 IF SDWLSTO["Y"
SET SDWLWR="OPEN"
+13 IF SDWLSP'=""
SET SDWLWR=$$EXTERNAL^DILFD(409.3,6,,SDWLSP)
+14 IF SDWLSPO["Y"
SET SDWLWR="OPEN"
+15 IF SDWLSS'=""
SET SDWLWR=$$EXTERNAL^DILFD(409.3,7,,SDWLSS)
+16 IF SDWLSSO["Y"
SET SDWLWR="OPEN"
+17 IF SDWLSC'=""
SET SDWLWR=$$EXTERNAL^DILFD(409.3,8,,SDWLSC)
+18 IF SDWLSCO["^"
SET SDWLWR="OPEN"
End DoDot:1
+19 SET YY=$EXTRACT(SDWLDT,1,3)+1700
SET YY=$EXTRACT(YY,3,4)
SET MM=$EXTRACT(SDWLDT,4,5)
SET DD=$EXTRACT(SDWLDT,6,7)
SET SDWLDTP=MM_DD_YY
+20 SET SDWLCLN=""
IF $DATA(^SC(+SDWLCL,0))
SET SDWLCLN=$$GET1^DIQ(44,SDWLCL_",",1,,)
+21 SET SDWLINN=$EXTRACT($PIECE($GET(^DIC(4,+SDWLIN,0)),U,1),1,8)
+22 SET SDWLDIS=$PIECE($GET(^SDWL(409.3,SDWLDA,"DIS")),U,3)
SET SDWLDISN=$$EXTERNAL^DILFD(409.3,21,,SDWLDIS)
+23 WRITE !,$EXTRACT(SDWLTYN,1,14),?22,SDWLPRI,?25,$EXTRACT(SDWLWR,1,19),?51,$EXTRACT(SDWLINN,1,14)
IF $DATA(SDWLDISC)
WRITE ?67,SDWLDSP
+24 WRITE ?73,SDWLDTP
+25 WRITE !,"DO YOU WISH TO REMOVE FROM LIST "
SET %=1
+26 DO YN^DICN
IF %=1
DO SB1
QUIT
+27 KILL DIR,X
+28 SET DIR(0)="S0^1:APPOINTMENT CRITERIA NOT MEET;2:PATIENT WANT ANOTHER APPOINTMENT;3:PROVIDER WANTS ANOTHER APPOINTMENT;4:OTHER"
+29 SET DIR("L",1)="SELECT ONE OF THE FOLLOWING REASONS:"
SET DIR("L",2)=""
+30 SET DIR("L",3)="1. APPOINTMENT CRITERIA NOT MEET"
SET DIR("L",4)="2. PATIENT WANTS ANOTHER APPOINTMENT"
+31 SET DIR("L",5)="3. PROVIDER WANTS ANOTHER APPOINTMENT"
SET DIR("L")="4. OTHER"
+32 DO ^DIR
+33 SET SDWLX=$SELECT(X="O":X="0",X="o":X=4,X="pr":X="PR",X="p":"P",X="a":"A",X=1:"A",X=2:"P",X=3:"PR",X=4:"O",X["A":"A",X="P":"P",X["^":"^",X="":"")
+34 IF SDWLX["^"
GOTO EN
IF SDWLX=""
GOTO END
+35 IF SDWLX="O"
Begin DoDot:1
+36 SET DIR(0)="FAO^^"
SET DIR("A")="Comments: "
DO ^DIR
IF X["^"
QUIT
+37 SET SDWLCOM=X
SET DA=SDWLDA
SET DIE="^SDWL(409.3,"
SET DR="18.1////^S X=SDWLCOM"
DO ^DIE
End DoDot:1
+38 SET DA=SDWLDA
+39 SET DIE="^SDWL(409.3,"
SET DR="18////^S X=SDWLX"
DO ^DIE
+40 SET DR="17////^S X=DUZ"
DO ^DIE
+41 SET DR="16////^S X=DT"
DO ^DIE
+42 KILL SDWLERR,DIR,DR,DIE,X,SDWLX,SDWLDSS,SDWLASK,SDWLDA,SDWLCOM
+43 QUIT
SB0 ;-Screen Appointment for valid clinic and/or service/specialty.
+1 SET SDWLDSS=+$PIECE(^SC(+SC,0),U,7)
SET SDWLASK=0
+2 SET SDWLDA=""
FOR
SET SDWLDA=$ORDER(^SDWL(409.3,"B",DFN,SDWLDA))
IF SDWLDA=""
QUIT
SET SDWLDA(SDWLDA)=""
+3 IF $DATA(^SDWL(409.3,"SC",+SC))
SET SDWLDA=""
FOR
SET SDWLDA=$ORDER(SDWLDA(SDWLDA))
IF SDWLDA=""
QUIT
IF $DATA(^SDWL(409.3,"SC",+SC,SDWLDA))
SET SDWLASK=1
SET SDWLDAV=SDWLDA
QUIT
+4 IF $DATA(^SDWL(409.3,"SS",DFN,SDWLDSS))
SET SDWLDA=""
FOR
SET SDWLDA=$ORDER(SDWLDA(SDWLDA))
IF SDWLDA=""
QUIT
IF $DATA(^SDWL(409.3,"SS",DFN,SDWLDSS,SDWLDA))
SET SDWLASK=2
SET SDWLDAV=SDWLDA
+5 IF $DATA(SDWLDAV)
SET SDWLDA=SDWLDAV
KILL SDWLDAV
+6 QUIT
SB1 ;-wants to remove patient from the wait list. Set Disposition
+1 IF $DATA(SDWLDA)
IF '$DATA(^SDWL(409.3,+SDWLDA))
IF SDWLERR=1
QUIT
+2 SET DA=SDWLDA
+3 SET DIE="^SDWL(409.3,"
SET DR="19////^S X=DT"
DO ^DIE
+4 SET DR="20////^S X=DUZ"
DO ^DIE
+5 SET DR="21////^S X=""SA"""
DO ^DIE
+6 SET DR="23////^S X=""C"""
DO ^DIE
+7 IF SDWLASK=1
KILL ^SDWL(409.3,"SC",SC,SDWLDA)
+8 IF SDWLASK=2
KILL ^SDWL(409.3,"SS",DFN,SDWLDSS,SDWLDA)
END KILL SDWLDT,SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLPRIN,SDWLTYN,SDWLST,SDWLSP,SDWLCLN,SDWLDTP,SDWLINN,SDWLDISN
+1 KILL SDWLPRI,SDWLWR,SDWLDA,SDWLSC,SDWLSS
+2 QUIT
