- 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