- SDWLI ;BPOI/TEH - DISPLAY PENDING APPOINTMENTS ;1/11/16 10:31am
- ;;5.3;scheduling;**263,327,394,446,524,505,611,645**;08/13/93;Build 7
- ;
- ;
- ;******************************************************************
- ; 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
- ; 01/14/2014 SD*5.3*611 Removed line
- ; 01/14/2014 SD*5.3*611 Changed DIC lookup to use PATIENT (#2) file
- ;
- ;
- ; Reference/ICR
- ; PATIENT FILE/10035
- ;
- ;
- 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")
- ;SD*5.3*611 removed line
- ;I $D(SDWLY),SDWLY S DIC("S")="I $P(^SDWL(409.3,+Y,0),U,17)=""O"""
- ;changed DIC lookup to the PATIENT (#2) file.
- S DIC(0)="EMNQA",DIC=2 D ^DIC S (SDWLDFN,DFN)=+Y
- 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
- .; SD*5.3*645 - replaced Date Desired with CID/Preferred Date
- .;S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD
- .S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?49,"CID/Preferred Date - ",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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLI 9463 printed Feb 19, 2025@00:29:14 Page 2
- SDWLI ;BPOI/TEH - DISPLAY PENDING APPOINTMENTS ;1/11/16 10:31am
- +1 ;;5.3;scheduling;**263,327,394,446,524,505,611,645**;08/13/93;Build 7
- +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 ; 01/14/2014 SD*5.3*611 Removed line
- +14 ; 01/14/2014 SD*5.3*611 Changed DIC lookup to use PATIENT (#2) file
- +15 ;
- +16 ;
- +17 ; Reference/ICR
- +18 ; PATIENT FILE/10035
- +19 ;
- +20 ;
- 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 ;SD*5.3*611 removed line
- +4 ;I $D(SDWLY),SDWLY S DIC("S")="I $P(^SDWL(409.3,+Y,0),U,17)=""O"""
- +5 ;changed DIC lookup to the PATIENT (#2) file.
- +6 SET DIC(0)="EMNQA"
- SET DIC=2
- DO ^DIC
- SET (SDWLDFN,DFN)=+Y
- +7 if SDWLDFN=""
- GOTO PATEND
- +8 if Y<0
- QUIT
- +9 if $DATA(DUOUT)
- QUIT
- +10 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 ; SD*5.3*645 - replaced Date Desired with CID/Preferred Date
- +25 ;S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD
- +26 SET SDWRB=0
- IF SDWLPRV
- WRITE !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?49,"CID/Preferred Date - ",SDWLDTD
- +27 IF SDWLPRV=1
- WRITE !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV)
- +28 IF $DATA(SDWLCOM)
- IF SDWLCOM'=""
- WRITE !,"Comments - ",SDWLCOM
- +29 IF $DATA(^TMP("SDWLI",$JOB,SDWLCNT,"SDOP"))
- NEW SDOP
- SET SDOP=^("SDOP")
- WRITE !,"Reopen Reason: ",$PIECE(SDOP,U)
- Begin DoDot:2
- +30 IF $PIECE(SDOP,U,2)'=""
- WRITE !,"Reopen comment: ",$PIECE(SDOP,U,2)
- End DoDot:2
- +31 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
- +32 IF $LENGTH(SDREMRC)>0
- WRITE !,"Non Removal Comment - ",SDREMRC
- +33 WRITE !,"Non Removal entry date - ",SDREMDD
- End DoDot:2
- +34 IF $DATA(^TMP("SDWLI",$JOB,SDWLCNT,"DIS"))
- WRITE !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT
- Begin DoDot:2
- +35 WRITE !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ)
- End DoDot:2
- +36 IF $DATA(^TMP("SDWLI",$JOB,SDWLCNT,"SDAPT"))
- NEW SDAP
- SET SDAP=^("SDAPT")
- Begin DoDot:2
- +37 WRITE !,"Appointment scheduled for "
- SET Y=$PIECE(SDAP,"~",2)
- DO DD^%DT
- WRITE Y
- +38 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
- +39 NEW SDAIN
- SET SDAIN=$PIECE(SDAP,U,3)
- SET SDAIN=$$GET1^DIQ(4,SDAIN_",",.01)
- +40 WRITE !?3,"Appt Institution: ",SDAIN
- +41 NEW SDCR
- SET SDCR=$PIECE(SDAP,U,4)
- SET SDCR=$$GET1^DIQ(40.7,SDCR_",",.01)
- +42 WRITE ?40,"Appt Specialty: ",SDCR
- +43 NEW SAPS
- SET SAPS=$PIECE(SDAP,U,8)
- SET SAPS=$PIECE(SAPS,"~")
- IF SAPS="CC"
- WRITE !,"Appointment Status: Canceled by Clinic"
- End DoDot:2
- +44 ; SD*5.3*446
- SET SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I")
- +45 ; SD*5.3*446
- if SDWLCLPT
- Begin DoDot:2
- +46 WRITE !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8)
- +47 if SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I")
- WRITE " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")"
- +48 QUIT
- End DoDot:2
- +49 ; Inter-facility Transfer. SD*5.3*446
- +50 IF $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN)
- DO ENS^%ZISS
- WRITE !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM
- DO KILL^%ZISS
- +51 DO GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP")
- +52 KILL SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN
- +53 WRITE !,"*****",!
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- Begin DoDot:2
- +54 IF X["^"
- SET DUOUT=1
- QUIT
- +55 IF 'Y
- SET DUOUT=1
- QUIT
- +56 ;I '$G(SDWLLIST) D HD
- End DoDot:2
- End DoDot:1
- IF $DATA(DUOUT)
- QUIT
- +57 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