source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLI.m@ 796

Last change on this file since 796 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1SDWLI ;BPOI/TEH - DISPLAY PENDING APPOINTMENTS;6/1/05
2 ;;5.3;scheduling;**263,327,394,446,524**;08/13/93;Build 29
3 ;
4 ;
5 ;******************************************************************
6 ; CHANGE LOG
7 ;
8 ; DATE PATCH DESCRIPTION
9 ; ---- ----- -----------
10 ; 04/22/2005 SD*5.3*327 DISPLAY APPOINTMENT INFORMATION
11 ; 04/22/2005 SD*5.3*327 UNDEFINED ERROR HD+1
12 ; 08/07/2006 SD*5.3*446 proceed only when DFN defined
13 ; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER
14 ;
15 ;
16EN ;NEW AND INITIALIZE VARIABLES
17 S SDWLERR=0
18 I $D(SDWLLIST),SDWLLIST D Q:SDWLERR
19 .I '$G(DFN) S SDWLERR=1 Q
20 .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
21 I $D(DUOUT) G END
22 I 'SDWLERR,$D(SDWLLIST),SDWLLIST D 1^VADPT,DEM^VADPT S SDWLDFN=DFN D HD K DIR,DIC,DR,DIE,VADM S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) G EN1
23 K DIR,DIC,DR,DIE,VADM
24 S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J)
25 ;
26 ;OPTION HEADER
27 ;
28 D HD
29 ;
30 ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0).
31 ;
32 D SEL G EN:$D(DUOUT)
33 D PAT Q:'$D(SDWLDFN)
34 G END:SDWLDFN<0,END:SDWLDFN=""
35 Q:$D(DUOUT)
36EN1 K DIR,DIC,DR,DIE,SDWLDRG
37 D GETFILE
38 D DISP G EN:'$D(DUOUT)
39 D END
40 Q
41PAT ;PATIENT LOOK-UP
42 ;PATCH SD*5.3*524 - SET DIC("S") FOR SCREEN OF OPEN/CLOSED ENTRIES
43 S DIC("S")="I $D(SDWLY),SDWLY,$P(^SDWL(409.3,+Y,0),U,17)=""O"""
44 S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2)
45 G PATEND:SDWLDFN=""
46 Q:Y<0
47 Q:$D(DUOUT)
48 D 1^VADPT
49PATEND Q
50 ;
51 ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES
52 ;
53SEL K SDWLDRG S DIR(0)="Y" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists",DIR("B")="YES"
54 S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records."
55 W ! D ^DIR S SDWLY=Y W !
56 I X["^" S DUOUT=1
57 I SDWLY=0 D SEL1
58 Q
59SEL1 K DIR,%DT(0) S SDWLDISC="",%DT="AE",%DT("A")="Start with Date Entered: " D ^%DT G SEL:Y<1 S SDWLBDT=Y
60 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")
61 Q
62 ;
63GETFILE ;GET DATA - OPTIONAL DATE RANGE IF SDWLDBT AND SDWLEDT VALID DATE RANGE
64 ;
65 K ^TMP("SDWLI",$J),SDWLDISX S SDWLDA=0,SDWLCNT=0 F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA="" D
66 .S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0)) I '$D(SDWLDRG),$P(SDWLDATA,U,17)["C" Q
67 .I '$P(SDWLDATA,U,3) Q
68 .N SDWLAPP S SDWLAPP="" I $D(^SDWL(409.3,SDWLDA,"SDAPT")) S SDWLAPP=^("SDAPT") D ;app data
69 ..S SDWLAPP=SDWLAPP_"~"_$P(SDWLDATA,U,23)
70 .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
71 .I $D(^SDWL(409.3,SDWLDA,"DIS")) D
72 ..S SDWLDISX=$G(^SDWL(409.3,SDWLDA,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2)
73 ..S SDWLDDT=$P(^SDWL(409.3,SDWLDA,"DIS"),U,1)
74 ..S SDWLDIDT="" I SDWLDDT'="" S SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3)
75 .I $D(^SDWL(409.3,SDWLDA,"DNR")) D
76 ..S SDREM=$G(^SDWL(409.3,SDWLDA,"DNR")) S SDREMD=$P(SDWLDATA,U,14),SDREMU=$P(SDWLDATA,U,15)
77 ..S SDREMDD="" I SDREMD'="" S SDREMDD=$E(SDREMD,4,5)_"/"_$E(SDREMD,6,7)_"/"_$E(SDREMD,2,3)
78 ..S SDREMR=$$GET1^DIQ(409.3,SDWLDA_",",18),SDREMRC=$$GET1^DIQ(409.3,SDWLDA_",",18.1,"I")
79 .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)
80 .S SDWLPROV=$P(SDWLDATA,U,13) I $D(SDWLDRG) D I SDNOK Q
81 ..S SDNOK=0
82 ..I SDWLDT<SDWLBDT!(SDWLDT>SDWLEDT) S SDNOK=1 Q
83 .;
84 .;IF STATUS IS CLOSED DO NOT DISPLAY RECORD
85 .;
86 .S SDWLCNT=SDWLCNT+1,^TMP("SDWLI",$J,SDWLCNT)=SDWLDATA_"~"_SDWLDA
87 .I $D(SDWLDISX) D
88 ..S ^TMP("SDWLI",$J,SDWLCNT,"DIS")=SDWLDIS_"^"_SDWLDDUZ_"^"_SDWLDIDT
89 ..I SDWLAPP>0 S ^TMP("SDWLI",$J,SDWLCNT,"SDAPT")=SDWLAPP
90 ..I SDOP'="" S ^TMP("SDWLI",$J,SDWLCNT,"SDOP")=SDOP
91 .I $D(SDREM) D
92 ..S ^TMP("SDWLI",$J,SDWLCNT,"REM")=SDREMR_U_SDREMRC_U_SDREMU_U_SDREMDD
93 .S ^TMP("SDWLI",$J)=SDWLCNT
94 .K SDWLDISX,SDREM
95 Q
96 ;
97DISP ;Display Wait List Data
98 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
99 F S SDWLCNT=$O(^TMP("SDWLI",$J,SDWLCNT)) Q:SDWLCNT="" D I $D(DUOUT) Q
100 .N SDWLDISX,SDWLR,SDWLCLPT
101 .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) S SDWLDISX=$G(^TMP("SDWLI",$J,SDWLCNT,"DIS"))
102 .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) S SDWLR=$G(^TMP("SDWLI",$J,SDWLCNT,"REM")) D
103 ..S SDREMR=$P(SDWLR,U),SDREMRC=$P(SDWLR,U,2),SDREMU=$P(SDWLR,U,3),SDREMDD=$P(SDWLR,U,4)
104 .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)
105 .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:"")
106 .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8),SDWLCOM=$P($P(X,U,18),"~",1)
107 .S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D
108 ..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3)
109 .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
110 .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
111 .;PATCH SD*5.3*394 See Note.
112 .N SDWLSCP
113 .S SDWLSCP=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2)
114 .W !,"# ",$J(SDWLCNT,3),!
115 .W !,"Wait List - ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY),?55,"Date Entered - ",SDWLDTP
116 .W !,?15 S X=$$EXTERNAL^DILFD(409.3,SDWLTYN,,SDWLTYP) W X
117 .S SDWLP=0 I SDWLPRI W !,"Priority - ",$$EXTERNAL^DILFD(409.3,10,,SDWLPRI) S SDWLP=1
118 .I $D(SDWLSCP) W !,"Service Connected Priority - ",$$EXTERNAL^DILFD(409.3,15,,SDWLSCP)
119 .W:SDWLP ?15 W:'SDWLP ! W "Institution - ",$$EXTERNAL^DILFD(409.3,2,,SDWLIN)
120 .W !,"Entered by - " S X=$$EXTERNAL^DILFD(409.3,9,,SDWLDUZ) W X
121 .S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD
122 .I SDWLPRV=1 W !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV)
123 .I $D(SDWLCOM),SDWLCOM'="" W !,"Comments - ",SDWLCOM
124 .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDOP")) N SDOP S SDOP=^("SDOP") W !,"Reopen Reason: ",$P(SDOP,U) D
125 ..I $P(SDOP,U,2)'="" W !,"Reopen comment: ",$P(SDOP,U,2)
126 .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) W !,"Non Removal Reason - ",SDREMR,!,"Non Remove Reason entered by - ",$$GET1^DIQ(200,SDREMU_",",.01,"I") D
127 ..I $L(SDREMRC)>0 W !,"Non Removal Comment - ",SDREMRC
128 ..W !,"Non Removal entry date - ",SDREMDD
129 .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) W !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT D
130 ..W !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ)
131 .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDAPT")) N SDAP S SDAP=^("SDAPT") D
132 ..W !,"Appointment scheduled for " S Y=$P(SDAP,"~",2) D DD^%DT W Y
133 ..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
134 ..N SDAIN S SDAIN=$P(SDAP,U,3),SDAIN=$$GET1^DIQ(4,SDAIN_",",.01)
135 ..W !?3,"Appt Institution: ",SDAIN
136 ..N SDCR S SDCR=$P(SDAP,U,4),SDCR=$$GET1^DIQ(40.7,SDCR_",",.01)
137 ..W ?40,"Appt Specialty: ",SDCR
138 ..N SAPS S SAPS=$P(SDAP,U,8),SAPS=$P(SAPS,"~") I SAPS="CC" W !,"Appointment Status: Canceled by Clinic"
139 .S SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I") ; SD*5.3*446
140 .D:SDWLCLPT ; SD*5.3*446
141 ..W !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8)
142 ..W:SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I") " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")"
143 ..Q
144 .; Inter-facility Transfer. SD*5.3*446
145 .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D ENS^%ZISS W !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM D KILL^%ZISS
146 .D GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP")
147 .K SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN
148 .W !,"*****",! K DIR S DIR(0)="E" D ^DIR D
149 ..I X["^" S DUOUT=1 Q
150 ..I 'Y S DUOUT=1 Q
151 ..D HD
152 Q
153HD ;Header
154 W:$D(IOF) @IOF W !!,?80-$L("Wait List - Inquiry")\2,"Wait List - Inquiry ",!
155 ;SD*5.3*327 - Correct undefined.
156 I '$D(SDWLDFN) W !! Q
157 N DFN S DFN=SDWLDFN D DEM^VADPT
158 W:$D(VADM) !,VADM(1),?40 I $D(VA("PID")) W VA("PID")
159 W !!
160 K DUOUT
161 Q
162END ;
163 K DIR,DIC,DR,DIE,SDWLDFN,DUOUT
164 K SDNOK,SDWLBDT,SDWLCL,SDWLCN,SDWLCNT,SDWLCOM,SDWLCT,SDWLDA,SDWLDATA,SDWLDDT,SDWLDDUZ,SDWLDFN,SDWLDIDT,SDWLDIS,SDWLDISX
165 K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY
166 K SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP
167 K SDREMD,SDREMDD,SDREMR,SDREMRC,SDREMU,MM,SDWLEDT,SDWLLIST,SDWLST,SDWLX,VA,X,Y,YY
168 Q
Note: See TracBrowser for help on using the repository browser.