SDWLI ;BPOI/TEH - DISPLAY PENDING APPOINTMENTS;6/1/05
;;5.3;scheduling;**263,327,394,446,524,505,1015**;08/13/93;Build 21
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 04/22/2005 SD*5.3*327 DISPLAY APPOINTMENT INFORMATION
; 04/22/2005 SD*5.3*327 UNDEFINED ERROR HD+1
; 08/07/2006 SD*5.3*446 proceed only when DFN defined
; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER
;
;
EN ;NEW AND INITIALIZE VARIABLES
S SDWLERR=0 N %DT,DD
I $D(SDWLLIST),SDWLLIST D Q:SDWLERR
.I '$G(DFN) S SDWLERR=1 Q
.I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)) D HD W *7,!,"This Patient has NO entries on the Electronic Wait List." S DIR(0)="E" D ^DIR S DUOUT=1 Q
I $D(DUOUT) G END
I 'SDWLERR,$D(SDWLLIST),SDWLLIST D 1^VADPT,DEM^VADPT S SDWLDFN=DFN D HD,SEL G END:$D(DUOUT) K DIR,DIC,DR,DIE,VADM S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) G EN1
K DIR,DIC,DR,DIE,VADM
S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J)
;
;OPTION HEADER
;
D HD
;
;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0).
;
D SEL G EN:$D(DUOUT)
D PAT Q:'$D(SDWLDFN)
G END:SDWLDFN<0,END:SDWLDFN=""
Q:$D(DUOUT)
EN1 K DIR,DIC,DR,DIE,SDWLDRG
D GETFILE
D DISP G EN:'$D(DUOUT)
D END
Q
PAT ;PATIENT LOOK-UP
;PATCH SD*5.3*524 - SET DIC("S") FOR SCREEN OF OPEN/CLOSED ENTRIES
K DIC,DIC("S")
I $D(SDWLY),SDWLY S DIC("S")="I $P(^SDWL(409.3,+Y,0),U,17)=""O"""
S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2)
G PATEND:SDWLDFN=""
Q:Y<0
Q:$D(DUOUT)
D 1^VADPT
PATEND Q
;
;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES
;
SEL K SDWLDRG S DIR(0)="Y" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists",DIR("B")="YES"
S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records."
W ! D ^DIR S SDWLY=Y W !
I X["^" S DUOUT=1 Q
I SDWLY=0 D SEL1
Q
SEL1 K DIR,%DT(0) S SDWLDISC="",%DT="AE",%DT("A")="Start with Date Entered: " D ^%DT G SEL:Y<1 S SDWLBDT=Y
S %DT(0)=SDWLBDT,%DT("A")="End with Date Entered: " D ^%DT G SEL1:Y<1 S SDWLEDT=Y,SDWLDRG="" K %DT(0),%DT("A")
Q
;
GETFILE ;GET DATA - OPTIONAL DATE RANGE IF SDWLDBT AND SDWLEDT VALID DATE RANGE
;
K ^TMP("SDWLI",$J),SDWLDISX S SDWLDA=0,SDWLCNT=0 F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA="" D
.S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0)) I '$D(SDWLDRG),SDWLY,$P(SDWLDATA,U,17)["C" Q
.I '$P(SDWLDATA,U,3) Q
.N SDWLAPP S SDWLAPP="" I $D(^SDWL(409.3,SDWLDA,"SDAPT")) S SDWLAPP=^("SDAPT") D ;app data
..S SDWLAPP=SDWLAPP_"~"_$P(SDWLDATA,U,23)
.N SDOP,SDOP1 S SDOP="" I $D(^SDWL(409.3,SDWLDA,1)) S SDOP=^(1),SDOP1=$$GET1^DIQ(409.3,SDWLDA_",",29),$P(SDOP,U)=SDOP1
.I $D(^SDWL(409.3,SDWLDA,"DIS")) D
..S SDWLDISX=$G(^SDWL(409.3,SDWLDA,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2)
..S SDWLDDT=$P(^SDWL(409.3,SDWLDA,"DIS"),U,1)
..S SDWLDIDT="" I SDWLDDT'="" S SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3)
.I $D(^SDWL(409.3,SDWLDA,"DNR")) D
..S SDREM=$G(^SDWL(409.3,SDWLDA,"DNR")) S SDREMD=$P(SDWLDATA,U,14),SDREMU=$P(SDWLDATA,U,15)
..S SDREMDD="" I SDREMD'="" S SDREMDD=$E(SDREMD,4,5)_"/"_$E(SDREMD,6,7)_"/"_$E(SDREMD,2,3)
..S SDREMR=$$GET1^DIQ(409.3,SDWLDA_",",18),SDREMRC=$$GET1^DIQ(409.3,SDWLDA_",",18.1,"I")
.S SDWLST=$P(SDWLDATA,U,6),SDWLSP=$P(SDWLDATA,U,7),SDWLSS=$P(SDWLDATA,U,8),SDWLSC=$P(SDWLDATA,U,9),SDWLDT=$P(SDWLDATA,U,2)
.S SDWLPROV=$P(SDWLDATA,U,13) I $D(SDWLDRG) D I SDNOK Q
..S SDNOK=0
..I SDWLDT<SDWLBDT!(SDWLDT>SDWLEDT) S SDNOK=1 Q
.;
.;IF STATUS IS CLOSED DO NOT DISPLAY RECORD
.;
.S SDWLCNT=SDWLCNT+1,^TMP("SDWLI",$J,SDWLCNT)=SDWLDATA_"~"_SDWLDA
.I $D(SDWLDISX) D
..S ^TMP("SDWLI",$J,SDWLCNT,"DIS")=SDWLDIS_"^"_SDWLDDUZ_"^"_SDWLDIDT
..I SDWLAPP>0 S ^TMP("SDWLI",$J,SDWLCNT,"SDAPT")=SDWLAPP
..I SDOP'="" S ^TMP("SDWLI",$J,SDWLCNT,"SDOP")=SDOP
.I $D(SDREM) D
..S ^TMP("SDWLI",$J,SDWLCNT,"REM")=SDREMR_U_SDREMRC_U_SDREMU_U_SDREMDD
.S ^TMP("SDWLI",$J)=SDWLCNT
.K SDWLDISX,SDREM
Q
;
DISP ;Display Wait List Data
S (SDWLDT,SDWLCNT,SDWLCN)="",SDWLCT=$G(^TMP("SDWLI",$J)) I 'SDWLCT W !!,"No 'OPEN' Wait List Records to Display.",!! K DIR S DIR(0)="E" D ^DIR S DUOUT="" Q
F S SDWLCNT=$O(^TMP("SDWLI",$J,SDWLCNT)) Q:SDWLCNT="" D I $D(DUOUT) Q
.N SDWLDISX,SDWLR,SDWLCLPT
.I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) S SDWLDISX=$G(^TMP("SDWLI",$J,SDWLCNT,"DIS"))
.I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) S SDWLR=$G(^TMP("SDWLI",$J,SDWLCNT,"REM")) D
..S SDREMR=$P(SDWLR,U),SDREMRC=$P(SDWLR,U,2),SDREMU=$P(SDWLR,U,3),SDREMDD=$P(SDWLR,U,4)
.S X=$G(^TMP("SDWLI",$J,SDWLCNT)),SDWLDA=$P(X,"~",2),SDWLIN=$P(X,U,3),SDWLCL=$P(X,U,4),SDWLTY=$P(X,U,5),SDWLPRI=$P(X,U,11)
.S SDWLTYP=$S(SDWLTY=1:$P(X,U,6),SDWLTY=2:$P(X,U,7),SDWLTY=3:$P(X,U,8),SDWLTY=4:$P(X,U,9),1:"")
.S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8),SDWLCOM=$P($P(X,U,18),"~",1)
.S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D
..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3)
.S SDWLDT=$P(X,U,2),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 SDWLDTD=$P(X,U,16),YY=$E(SDWLDTD,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDTD,4,5),DD=$E(SDWLDTD,6,7),SDWLDTD=MM_"/"_DD_"/"_YY
.;PATCH SD*5.3*394 See Note.
.N SDWLSCP
.S SDWLSCP=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2)
.W !,"# ",$J(SDWLCNT,3),!
.W !,"Wait List - ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY),?55,"Date Entered - ",SDWLDTP
.W !,?15 S X=$$EXTERNAL^DILFD(409.3,SDWLTYN,,SDWLTYP) W X
.S SDWLP=0 I SDWLPRI W !,"Priority - ",$$EXTERNAL^DILFD(409.3,10,,SDWLPRI) S SDWLP=1
.I $D(SDWLSCP) W !,"Service Connected Priority - ",$$EXTERNAL^DILFD(409.3,15,,SDWLSCP)
.W:SDWLP ?15 W:'SDWLP ! W "Institution - ",$$EXTERNAL^DILFD(409.3,2,,SDWLIN)
.W !,"Entered by - " S X=$$EXTERNAL^DILFD(409.3,9,,SDWLDUZ) W X
.S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD
.I SDWLPRV=1 W !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV)
.I $D(SDWLCOM),SDWLCOM'="" W !,"Comments - ",SDWLCOM
.I $D(^TMP("SDWLI",$J,SDWLCNT,"SDOP")) N SDOP S SDOP=^("SDOP") W !,"Reopen Reason: ",$P(SDOP,U) D
..I $P(SDOP,U,2)'="" W !,"Reopen comment: ",$P(SDOP,U,2)
.I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) W !,"Non Removal Reason - ",SDREMR,!,"Non Remove Reason entered by - ",$$GET1^DIQ(200,SDREMU_",",.01,"I") D
..I $L(SDREMRC)>0 W !,"Non Removal Comment - ",SDREMRC
..W !,"Non Removal entry date - ",SDREMDD
.I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) W !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT D
..W !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ)
.I $D(^TMP("SDWLI",$J,SDWLCNT,"SDAPT")) N SDAP S SDAP=^("SDAPT") D
..W !,"Appointment scheduled for " S Y=$P(SDAP,"~",2) D DD^%DT W Y
..W !?3,"Made on: " S Y=+SDAP D DD^%DT W Y,?30,"For clinic: " N SDC S SDC=$P(SDAP,U,2) S SDC=$$GET1^DIQ(44,SDC_",",.01) W SDC
..N SDAIN S SDAIN=$P(SDAP,U,3),SDAIN=$$GET1^DIQ(4,SDAIN_",",.01)
..W !?3,"Appt Institution: ",SDAIN
..N SDCR S SDCR=$P(SDAP,U,4),SDCR=$$GET1^DIQ(40.7,SDCR_",",.01)
..W ?40,"Appt Specialty: ",SDCR
..N SAPS S SAPS=$P(SDAP,U,8),SAPS=$P(SAPS,"~") I SAPS="CC" W !,"Appointment Status: Canceled by Clinic"
.S SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I") ; SD*5.3*446
.D:SDWLCLPT ; SD*5.3*446
..W !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8)
..W:SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I") " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")"
..Q
.; Inter-facility Transfer. SD*5.3*446
.I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D ENS^%ZISS W !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM D KILL^%ZISS
.D GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP")
.K SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN
.W !,"*****",! K DIR S DIR(0)="E" D ^DIR D
..I X["^" S DUOUT=1 Q
..I 'Y S DUOUT=1 Q
..;I '$G(SDWLLIST) D HD
Q
HD ;Header
W:$D(IOF) @IOF W !!,?80-$L("Wait List - Inquiry")\2,"Wait List - Inquiry ",!
;SD*5.3*327 - Correct undefined.
I '$D(SDWLDFN) W !! Q
N DFN S DFN=SDWLDFN D DEM^VADPT
W:$D(VADM) !,VADM(1),?40 I $D(VA("PID")) W VA("PID")
W !!
K DUOUT
Q
END ;
K DIR,DIC,DR,DIE,SDWLDFN,DUOUT
K SDNOK,SDWLBDT,SDWLCL,SDWLCN,SDWLCNT,SDWLCOM,SDWLCT,SDWLDA,SDWLDATA,SDWLDDT,SDWLDDUZ,SDWLDFN,SDWLDIDT,SDWLDIS,SDWLDISX
K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY
K SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP
K SDREMD,SDREMDD,SDREMR,SDREMRC,SDREMU,MM,SDWLEDT,SDWLLIST,SDWLST,SDWLX,VA,X,Y,YY
Q
SDWLI ;BPOI/TEH - DISPLAY PENDING APPOINTMENTS;6/1/05
+1 ;;5.3;scheduling;**263,327,394,446,524,505,1015**;08/13/93;Build 21
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ; 04/22/2005 SD*5.3*327 DISPLAY APPOINTMENT INFORMATION
+10 ; 04/22/2005 SD*5.3*327 UNDEFINED ERROR HD+1
+11 ; 08/07/2006 SD*5.3*446 proceed only when DFN defined
+12 ; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER
+13 ;
+14 ;
EN ;NEW AND INITIALIZE VARIABLES
+1 SET SDWLERR=0
NEW %DT,DD
+2 IF $DATA(SDWLLIST)
IF SDWLLIST
Begin DoDot:1
+3 IF '$GET(DFN)
SET SDWLERR=1
QUIT
+4 IF $DATA(DFN)
IF DFN'=""
IF '$DATA(^SDWL(409.3,"B",DFN))
DO HD
WRITE *7,!,"This Patient has NO entries on the Electronic Wait List."
SET DIR(0)="E"
DO ^DIR
SET DUOUT=1
QUIT
End DoDot:1
IF SDWLERR
QUIT
+5 IF $DATA(DUOUT)
GOTO END
+6 IF 'SDWLERR
IF $DATA(SDWLLIST)
IF SDWLLIST
DO 1^VADPT
DO DEM^VADPT
SET SDWLDFN=DFN
DO HD
DO SEL
IF $DATA(DUOUT)
GOTO END
KILL DIR,DIC,DR,DIE,VADM
SET (SDWLBDT,SDWLEDT)=""
KILL ^TMP("SDWLI",$JOB)
GOTO EN1
+7 KILL DIR,DIC,DR,DIE,VADM
+8 SET (SDWLBDT,SDWLEDT)=""
KILL ^TMP("SDWLI",$JOB)
+9 ;
+10 ;OPTION HEADER
+11 ;
+12 DO HD
+13 ;
+14 ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0).
+15 ;
+16 DO SEL
IF $DATA(DUOUT)
GOTO EN
+17 DO PAT
IF '$DATA(SDWLDFN)
QUIT
+18 IF SDWLDFN<0
GOTO END
IF SDWLDFN=""
GOTO END
+19 IF $DATA(DUOUT)
QUIT
EN1 KILL DIR,DIC,DR,DIE,SDWLDRG
+1 DO GETFILE
+2 DO DISP
IF '$DATA(DUOUT)
GOTO EN
+3 DO END
+4 QUIT
PAT ;PATIENT LOOK-UP
+1 ;PATCH SD*5.3*524 - SET DIC("S") FOR SCREEN OF OPEN/CLOSED ENTRIES
+2 KILL DIC,DIC("S")
+3 IF $DATA(SDWLY)
IF SDWLY
SET DIC("S")="I $P(^SDWL(409.3,+Y,0),U,17)=""O"""
+4 SET DIC(0)="EMNQA"
SET DIC=409.3
DO ^DIC
SET (SDWLDFN,DFN)=$PIECE(Y,U,2)
+5 IF SDWLDFN=""
GOTO PATEND
+6 IF Y<0
QUIT
+7 IF $DATA(DUOUT)
QUIT
+8 DO 1^VADPT
PATEND QUIT
+1 ;
+2 ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES
+3 ;
SEL KILL SDWLDRG
SET DIR(0)="Y"
SET DIR("A")="Do You Want to View Only 'OPEN' Wait Lists"
SET DIR("B")="YES"
+1 SET DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records."
+2 WRITE !
DO ^DIR
SET SDWLY=Y
WRITE !
+3 IF X["^"
SET DUOUT=1
QUIT
+4 IF SDWLY=0
DO SEL1
+5 QUIT
SEL1 KILL DIR,%DT(0)
SET SDWLDISC=""
SET %DT="AE"
SET %DT("A")="Start with Date Entered: "
DO ^%DT
IF Y<1
GOTO SEL
SET SDWLBDT=Y
+1 SET %DT(0)=SDWLBDT
SET %DT("A")="End with Date Entered: "
DO ^%DT
IF Y<1
GOTO SEL1
SET SDWLEDT=Y
SET SDWLDRG=""
KILL %DT(0),%DT("A")
+2 QUIT
+3 ;
GETFILE ;GET DATA - OPTIONAL DATE RANGE IF SDWLDBT AND SDWLEDT VALID DATE RANGE
+1 ;
+2 KILL ^TMP("SDWLI",$JOB),SDWLDISX
SET SDWLDA=0
SET SDWLCNT=0
FOR
SET SDWLDA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDA))
IF SDWLDA=""
QUIT
Begin DoDot:1
+3 SET SDWLDATA=$GET(^SDWL(409.3,SDWLDA,0))
IF '$DATA(SDWLDRG)
IF SDWLY
IF $PIECE(SDWLDATA,U,17)["C"
QUIT
+4 IF '$PIECE(SDWLDATA,U,3)
QUIT
+5 ;app data
NEW SDWLAPP
SET SDWLAPP=""
IF $DATA(^SDWL(409.3,SDWLDA,"SDAPT"))
SET SDWLAPP=^("SDAPT")
Begin DoDot:2
+6 SET SDWLAPP=SDWLAPP_"~"_$PIECE(SDWLDATA,U,23)
End DoDot:2
+7 NEW SDOP,SDOP1
SET SDOP=""
IF $DATA(^SDWL(409.3,SDWLDA,1))
SET SDOP=^(1)
SET SDOP1=$$GET1^DIQ(409.3,SDWLDA_",",29)
SET $PIECE(SDOP,U)=SDOP1
+8 IF $DATA(^SDWL(409.3,SDWLDA,"DIS"))
Begin DoDot:2
+9 SET SDWLDISX=$GET(^SDWL(409.3,SDWLDA,"DIS"))
SET SDWLDIS=$PIECE(SDWLDISX,U,3)
SET SDWLDDUZ=$PIECE(SDWLDISX,U,2)
+10 SET SDWLDDT=$PIECE(^SDWL(409.3,SDWLDA,"DIS"),U,1)
+11 SET SDWLDIDT=""
IF SDWLDDT'=""
SET SDWLDIDT=$EXTRACT(SDWLDDT,4,5)_"/"_$EXTRACT(SDWLDDT,6,7)_"/"_$EXTRACT(SDWLDDT,2,3)
End DoDot:2
+12 IF $DATA(^SDWL(409.3,SDWLDA,"DNR"))
Begin DoDot:2
+13 SET SDREM=$GET(^SDWL(409.3,SDWLDA,"DNR"))
SET SDREMD=$PIECE(SDWLDATA,U,14)
SET SDREMU=$PIECE(SDWLDATA,U,15)
+14 SET SDREMDD=""
IF SDREMD'=""
SET SDREMDD=$EXTRACT(SDREMD,4,5)_"/"_$EXTRACT(SDREMD,6,7)_"/"_$EXTRACT(SDREMD,2,3)
+15 SET SDREMR=$$GET1^DIQ(409.3,SDWLDA_",",18)
SET SDREMRC=$$GET1^DIQ(409.3,SDWLDA_",",18.1,"I")
End DoDot:2
+16 SET SDWLST=$PIECE(SDWLDATA,U,6)
SET SDWLSP=$PIECE(SDWLDATA,U,7)
SET SDWLSS=$PIECE(SDWLDATA,U,8)
SET SDWLSC=$PIECE(SDWLDATA,U,9)
SET SDWLDT=$PIECE(SDWLDATA,U,2)
+17 SET SDWLPROV=$PIECE(SDWLDATA,U,13)
IF $DATA(SDWLDRG)
Begin DoDot:2
+18 SET SDNOK=0
+19 IF SDWLDT<SDWLBDT!(SDWLDT>SDWLEDT)
SET SDNOK=1
QUIT
End DoDot:2
IF SDNOK
QUIT
+20 ;
+21 ;IF STATUS IS CLOSED DO NOT DISPLAY RECORD
+22 ;
+23 SET SDWLCNT=SDWLCNT+1
SET ^TMP("SDWLI",$JOB,SDWLCNT)=SDWLDATA_"~"_SDWLDA
+24 IF $DATA(SDWLDISX)
Begin DoDot:2
+25 SET ^TMP("SDWLI",$JOB,SDWLCNT,"DIS")=SDWLDIS_"^"_SDWLDDUZ_"^"_SDWLDIDT
+26 IF SDWLAPP>0
SET ^TMP("SDWLI",$JOB,SDWLCNT,"SDAPT")=SDWLAPP
+27 IF SDOP'=""
SET ^TMP("SDWLI",$JOB,SDWLCNT,"SDOP")=SDOP
End DoDot:2
+28 IF $DATA(SDREM)
Begin DoDot:2
+29 SET ^TMP("SDWLI",$JOB,SDWLCNT,"REM")=SDREMR_U_SDREMRC_U_SDREMU_U_SDREMDD
End DoDot:2
+30 SET ^TMP("SDWLI",$JOB)=SDWLCNT
+31 KILL SDWLDISX,SDREM
End DoDot:1
+32 QUIT
+33 ;
DISP ;Display Wait List Data
+1 SET (SDWLDT,SDWLCNT,SDWLCN)=""
SET SDWLCT=$GET(^TMP("SDWLI",$JOB))
IF 'SDWLCT
WRITE !!,"No 'OPEN' Wait List Records to Display.",!!
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DUOUT=""
QUIT
+2 FOR
SET SDWLCNT=$ORDER(^TMP("SDWLI",$JOB,SDWLCNT))
IF SDWLCNT=""
QUIT
Begin DoDot:1
+3 NEW SDWLDISX,SDWLR,SDWLCLPT
+4 IF $DATA(^TMP("SDWLI",$JOB,SDWLCNT,"DIS"))
SET SDWLDISX=$GET(^TMP("SDWLI",$JOB,SDWLCNT,"DIS"))
+5 IF $DATA(^TMP("SDWLI",$JOB,SDWLCNT,"REM"))
SET SDWLR=$GET(^TMP("SDWLI",$JOB,SDWLCNT,"REM"))
Begin DoDot:2
+6 SET SDREMR=$PIECE(SDWLR,U)
SET SDREMRC=$PIECE(SDWLR,U,2)
SET SDREMU=$PIECE(SDWLR,U,3)
SET SDREMDD=$PIECE(SDWLR,U,4)
End DoDot:2
+7 SET X=$GET(^TMP("SDWLI",$JOB,SDWLCNT))
SET SDWLDA=$PIECE(X,"~",2)
SET SDWLIN=$PIECE(X,U,3)
SET SDWLCL=$PIECE(X,U,4)
SET SDWLTY=$PIECE(X,U,5)
SET SDWLPRI=$PIECE(X,U,11)
+8 SET SDWLTYP=$SELECT(SDWLTY=1:$PIECE(X,U,6),SDWLTY=2:$PIECE(X,U,7),SDWLTY=3:$PIECE(X,U,8),SDWLTY=4:$PIECE(X,U,9),1:"")
+9 SET SDWLTYN=$SELECT(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8)
SET SDWLCOM=$PIECE($PIECE(X,U,18),"~",1)
+10 SET SDWLDUZ=$PIECE(X,U,10)
SET SDWLPRV=$PIECE(X,U,12)
SET SDWLPROV=$PIECE(X,U,13)
SET SDWLX=$PIECE(X,"~",3)
Begin DoDot:2
+11 IF $DATA(SDWLDISX)
SET SDWLDIS=$PIECE(SDWLDISX,U,1)
SET SDWLDDUZ=$PIECE(SDWLDISX,U,2)
SET SDWLDIDT=$PIECE(SDWLDISX,U,3)
End DoDot:2
+12 SET SDWLDT=$PIECE(X,U,2)
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
+13 SET SDWLDTD=$PIECE(X,U,16)
SET YY=$EXTRACT(SDWLDTD,1,3)+1700
SET YY=$EXTRACT(YY,3,4)
SET MM=$EXTRACT(SDWLDTD,4,5)
SET DD=$EXTRACT(SDWLDTD,6,7)
SET SDWLDTD=MM_"/"_DD_"/"_YY
+14 ;PATCH SD*5.3*394 See Note.
+15 NEW SDWLSCP
+16 SET SDWLSCP=+$PIECE($GET(^SDWL(409.3,SDWLDA,"SC")),U,2)
+17 WRITE !,"# ",$JUSTIFY(SDWLCNT,3),!
+18 WRITE !,"Wait List - ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY),?55,"Date Entered - ",SDWLDTP
+19 WRITE !,?15
SET X=$$EXTERNAL^DILFD(409.3,SDWLTYN,,SDWLTYP)
WRITE X
+20 SET SDWLP=0
IF SDWLPRI
WRITE !,"Priority - ",$$EXTERNAL^DILFD(409.3,10,,SDWLPRI)
SET SDWLP=1
+21 IF $DATA(SDWLSCP)
WRITE !,"Service Connected Priority - ",$$EXTERNAL^DILFD(409.3,15,,SDWLSCP)
+22 IF SDWLP
WRITE ?15
IF 'SDWLP
WRITE !
WRITE "Institution - ",$$EXTERNAL^DILFD(409.3,2,,SDWLIN)
+23 WRITE !,"Entered by - "
SET X=$$EXTERNAL^DILFD(409.3,9,,SDWLDUZ)
WRITE X
+24 SET SDWRB=0
IF SDWLPRV
WRITE !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD
+25 IF SDWLPRV=1
WRITE !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV)
+26 IF $DATA(SDWLCOM)
IF SDWLCOM'=""
WRITE !,"Comments - ",SDWLCOM
+27 IF $DATA(^TMP("SDWLI",$JOB,SDWLCNT,"SDOP"))
NEW SDOP
SET SDOP=^("SDOP")
WRITE !,"Reopen Reason: ",$PIECE(SDOP,U)
Begin DoDot:2
+28 IF $PIECE(SDOP,U,2)'=""
WRITE !,"Reopen comment: ",$PIECE(SDOP,U,2)
End DoDot:2
+29 IF $DATA(^TMP("SDWLI",$JOB,SDWLCNT,"REM"))
WRITE !,"Non Removal Reason - ",SDREMR,!,"Non Remove Reason entered by - ",$$GET1^DIQ(200,SDREMU_",",.01,"I")
Begin DoDot:2
+30 IF $LENGTH(SDREMRC)>0
WRITE !,"Non Removal Comment - ",SDREMRC
+31 WRITE !,"Non Removal entry date - ",SDREMDD
End DoDot:2
+32 IF $DATA(^TMP("SDWLI",$JOB,SDWLCNT,"DIS"))
WRITE !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT
Begin DoDot:2
+33 WRITE !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ)
End DoDot:2
+34 IF $DATA(^TMP("SDWLI",$JOB,SDWLCNT,"SDAPT"))
NEW SDAP
SET SDAP=^("SDAPT")
Begin DoDot:2
+35 WRITE !,"Appointment scheduled for "
SET Y=$PIECE(SDAP,"~",2)
DO DD^%DT
WRITE Y
+36 WRITE !?3,"Made on: "
SET Y=+SDAP
DO DD^%DT
WRITE Y,?30,"For clinic: "
NEW SDC
SET SDC=$PIECE(SDAP,U,2)
SET SDC=$$GET1^DIQ(44,SDC_",",.01)
WRITE SDC
+37 NEW SDAIN
SET SDAIN=$PIECE(SDAP,U,3)
SET SDAIN=$$GET1^DIQ(4,SDAIN_",",.01)
+38 WRITE !?3,"Appt Institution: ",SDAIN
+39 NEW SDCR
SET SDCR=$PIECE(SDAP,U,4)
SET SDCR=$$GET1^DIQ(40.7,SDCR_",",.01)
+40 WRITE ?40,"Appt Specialty: ",SDCR
+41 NEW SAPS
SET SAPS=$PIECE(SDAP,U,8)
SET SAPS=$PIECE(SAPS,"~")
IF SAPS="CC"
WRITE !,"Appointment Status: Canceled by Clinic"
End DoDot:2
+42 ; SD*5.3*446
SET SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I")
+43 ; SD*5.3*446
IF SDWLCLPT
Begin DoDot:2
+44 WRITE !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8)
+45 IF SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I")
WRITE " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")"
+46 QUIT
End DoDot:2
+47 ; Inter-facility Transfer. SD*5.3*446
+48 IF $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN)
DO ENS^%ZISS
WRITE !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM
DO KILL^%ZISS
+49 DO GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP")
+50 KILL SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN
+51 WRITE !,"*****",!
KILL DIR
SET DIR(0)="E"
DO ^DIR
Begin DoDot:2
+52 IF X["^"
SET DUOUT=1
QUIT
+53 IF 'Y
SET DUOUT=1
QUIT
+54 ;I '$G(SDWLLIST) D HD
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+55 QUIT
HD ;Header
+1 IF $DATA(IOF)
WRITE @IOF
WRITE !!,?80-$LENGTH("Wait List - Inquiry")\2,"Wait List - Inquiry ",!
+2 ;SD*5.3*327 - Correct undefined.
+3 IF '$DATA(SDWLDFN)
WRITE !!
QUIT
+4 NEW DFN
SET DFN=SDWLDFN
DO DEM^VADPT
+5 IF $DATA(VADM)
WRITE !,VADM(1),?40
IF $DATA(VA("PID"))
WRITE VA("PID")
+6 WRITE !!
+7 KILL DUOUT
+8 QUIT
END ;
+1 KILL DIR,DIC,DR,DIE,SDWLDFN,DUOUT
+2 KILL SDNOK,SDWLBDT,SDWLCL,SDWLCN,SDWLCNT,SDWLCOM,SDWLCT,SDWLDA,SDWLDATA,SDWLDDT,SDWLDDUZ,SDWLDFN,SDWLDIDT,SDWLDIS,SDWLDISX
+3 KILL SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY
+4 KILL SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP
+5 KILL SDREMD,SDREMDD,SDREMR,SDREMRC,SDREMU,MM,SDWLEDT,SDWLLIST,SDWLST,SDWLX,VA,X,Y,YY
+6 QUIT
