source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLEVAL.m@ 1764

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1SDWLEVAL ;;IOFO BAY PINES/ESW - WAIT LIST - DISPOSITION AFTER APPOINTMENT(S) ENTRY;06/12/2002 ; 5/23/05 4:47pm ; Compiled April 20, 2006 17:36:31 ; Compiled May 2, 2006 10:03:55 ; Compiled May 1, 2007 15:18:38
2 ;;5.3;Scheduling;**327,471,446**;AUG 13 1993;Build 77
3 ;Evaluate appt for optional disposition
4 ;called from SDMM, SDMM1, SDM1A, SDAM2 ; replaced SDWLR
5 ;
6EN(DFN,SDYN) ;evaluation if patient is on EWL
7 ; SDYN passed by reference
8 ;output: SDYN=0 - no open entries in EWL
9 ; SDYN=1 - at least one open entry in EWL
10 S SDYN=0,SDYN(1)=""
11 I '$D(DFN)!(DFN'?1.N) S SDYN(1)="Patient's DFN not passed." Q
12 I $D(DFN),'$D(^SDWL(409.3,"B",DFN)) S SDYN(1)="This patient is not on EWL." Q
13 S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",DFN,SDWLDA)) Q:SDWLDA="" D Q:SDYN=1
14 .I $P($G(^SDWL(409.3,SDWLDA,0)),"^",17)="O" S SDYN=1,SDYN(1)="Patient has open Wait List entries."
15 I SDYN=0 S SDYN(1)="Patient has no open Wait List entries."
16 Q
17EWLANS(SDCONT) ;display EWL OPEN entries
18 ;check if to continue with EWL open entries
19 S SDCONT=0
20 N X,DIR,Y
21 S DIR("B")="NO"
22 S DIR("A")="Do you want to display open Wait list entries (Yes/No)?",DIR(0)="Y"
23 S DIR("?")="Do you want to review open EWL entries for Dispositioning?"
24 D ^DIR
25 I Y S SDCONT=1
26 Q
27ASKREM ;prompt user for record for dispositioning
28 S SDDIS=0 ; flag indicating disposition
29 W ! N X,DIR,Y
30 S DIR("B")="NO"
31 S DIR("A")="DO YOU WISH TO REMOVE ANY ENTRY FROM LIST (Yes/No)? ",DIR(0)="Y"
32 S DIR("?")="To disposition any entry based on scheduled appointments."
33 D ^DIR
34 I Y S SDDIS=1
35 D ANSW(SDDIS)
36 Q
37ANSW(SDDIS,SDR) ;
38 ;SDDIS=0 - select entries not to disposition
39 ;SDDIS=1 - select entries to disposition
40 N DIR,X I '$D(SDR) S SDR=0
41 W !
42 N STR,SS,SDCB S SDC=$O(^TMP($J,"SDWLPL",""),-1),SDCB=$O(^TMP($J,"SDWLPL",""))
43 ;I SDC=SDCB S DIR("B")=SDC
44 ;E S DIR("B")=SDCB_"-"_SDC
45 S DIR(0)="L^"_SDCB_":"_SDC S DIR("A")="You must select one of the above EWL entries and then enter a non-removal reason: ",DIR("?")="Enter number(s) or range of displayed Wait List entries."
46 I SDDIS S DIR("A")="Select one of the above open EWL entries to close with an appointment or enter '^' to continue>"
47 D ^DIR
48 N SDAN S SDAN=X I SDAN="^" Q
49 I SDAN["-" D
50 .N SXB,SXE
51 .S SXB=$P(SDAN,"-"),SXE=$P(SDAN,"-",2) N SDC F SDC=SXB:1:SXE I $D(^TMP($J,"SDWLPL",SDC)) S SDWLDA=+^TMP($J,"SDWLPL",SDC) D
52 ..;LOCK
53 ..L +^SDWL(409.3,SDWLDA):5 I '$T W !,"Another User is Editing this Entry. Try Later." Q
54 ..I 'SDDIS N SDR F D DISPO(SDWLDA,SDC,.SDR) Q:SDR
55 ..I SDDIS D GETDATA(SDWLDA) D DISEND(SDWLDA,SDC) S SDR=1
56 ..L
57 I SDAN[","!(SDAN?1N) D
58 .N FF S FF=SDAN N GG,SDC F GG=1:1 S SDC=$P(FF,",",GG) Q:SDC="" I $D(^TMP($J,"SDWLPL",SDC)) S SDWLDA=+^TMP($J,"SDWLPL",SDC) D
59 ..;LOCK
60 ..L +^SDWL(409.3,SDWLDA):5 I '$T W !,"Another User is Editing this Entry. Try Later." Q
61 ..I 'SDDIS N SDR F D DISPO(SDWLDA,SDC,.SDR) Q:SDR
62 ..I SDDIS D GETDATA(SDWLDA) D DISEND(SDWLDA,SDC) S SDR=1
63 ..L
64 Q
65DISEND(SDWLDA,SDC) ;display and disposition
66 ;SDWLDA - IEN of 409.3
67 N DUOUT D EDIT(SDWLDA,SDC,.SDWLERR) Q:$G(DUOUT) I SDWLERR Q
68 W !!,"*** Patient has been removed from Wait List ***",!
69 K ^TMP($J,"SDWLPL",SDC)
70 K DIR,DIE,DR,DIC
71 Q
72GETDATA(SDWLDA) ;retrieval data
73 N SDWLCL,SDWLDAPT,SDWLDATA,SDWLDISP,SDWLDUZ,SDWLEDT,SDWLIN,SDWLPRI,SDWLPROV,SDWLRB,SDWLSC,SDWLSP,SDWLST,SDWLTY
74 S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0))
75 S SDWLIN=$P(SDWLDATA,U,3),SDWLCL=+$P(SDWLDATA,U,4),SDWLTY=$P(SDWLDATA,U,5),SDWLST=$P(SDWLDATA,U,6)
76 S SDWLSP=$P(SDWLDATA,U,7),SDWLSS=$P(SDWLDATA,U,8),SDWLSC=$P(SDWLDATA,U,9),SDWLPRI=$P(SDWLDATA,U,10),SDWLRB=$P(SDWLDATA,U,11)
77 S SDWLPROV=$P(SDWLDATA,U,12),SDWLDAPT=$P(SDWLDATA,U,16),SDWLST=$P(SDWLDATA,U,17),SDWLDUZ=DUZ,SDWLEDT=DT
78 S SDWLSCL="" I SDWLSC S SDWLSCL=+$P(^SDWL(409.32,SDWLSC,0),U,1)
79 I $D(^SDWL(409.3,SDWLDA,"DIS")) S SDWLDISP=$P(^SDWL(409.3,SDWLDA,"DIS"),U,3)
80 Q
81EDIT(SDWLDA,SDC,SDWLERR) ;ENTER/EDIT DISPOSITION
82 ;SDWLDA -IEN of selected 409.3 entry
83 ;SDWLERR - called by a reference
84 ;SDC - sequential number in ^TMP($J,"SDWLPL",SDC
85 S SDWLDUZ=DUZ,SDWLERR=0 S SDWLDISP="SA" D EDITSA Q ;N DIR,DR,DIE,DIC
86EDITSA I SDWLDISP="SA" D
87 .I $O(^TMP($J,"APPT",""))=$O(^TMP($J,"APPT",""),-1) S SDAP=$O(^TMP($J,"APPT","")) Q
88 .I $O(^TMP($J,"APPT",""))'=$O(^TMP($J,"APPT",""),-1) D APPTD D I SDAP="^" W !,"Disposition canceled by user",! Q
89 ..W ! K DIR,X
90 ..N STR,SS,SDA S SDA=$O(^TMP($J,"APPT",""),-1) I SDA=1 S DIR("B")=1
91 ..S DIR(0)="N^1:"_SDA S DIR("A")="Select appt for Removal Reason or '^' to Quit>",DIR("?")="Select Appointment to close with the open EWL."
92 ..D ^DIR
93 ..S SDAP=X
94 S DIE="^SDWL(409.3,",DA=SDWLDA,DR="21////^S X=SDWLDISP" D ^DIE
95 S DR="19////^S X=DT" D ^DIE
96 S DR="20////^S X=SDWLDUZ" D ^DIE
97 S DR="23////^S X=""C""" D ^DIE
98 ;if "SA" update with appoint data
99 ;get appt data to file (for a particular appt #)
100 I SDWLDISP="SA" N SDA D DATP(SDAP,.SDA) D
101 .I $D(SDA) S DIE="^SDWL(409.3,",DA=SDWLDA D
102 ..S DR="13////"_SDA(1)_";13.1////"_DT_";13.2////"_SDA(2)_";13.3////"_SDA(15)_";13.4////"_SDA(13)_";13.5////"_SDA(14)_";13.6////"_SDA(16)_";13.8////"_SDA(3)_";13.7////"_DUZ
103 ..D ^DIE
104 N SDWLSCL,SDWLSS,SDWLDFN
105 S SDWLSCL=$P($G(^TMP($J,"SDWLPL",SDC)),U,9)
106 S SDWLSS=$P($G(^TMP($J,"SDWLPL",SDC)),U,10)
107 I SDWLSCL K:$D(^SDWL(409.3,"SC",SDWLSCL,SDWLDA)) ^SDWL(409.3,"SC",SDWLSCL,SDWLDA)
108 S SDWLDFN=$P($G(^TMP($J,"APPT",1)),U,4)
109 I SDWLSS,SDWLDFN K:$D(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)) ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)
110 Q
111DISPO(SDWLDA,SDC,SDR) ;
112 ;SDWLDA - IEN of 409.3
113 ;SDC - seq in ^TMP($J,"SDWLPL",SDC
114 ;out SDR - NON REMOVAL:
115 ; 1 entered
116 ; 0 not entered
117 K DIR,X S SDR=0
118 S DIR(0)="SM^1:APPOINTMENT CRITERIA NOT MET;2:PATIENT WANTS ANOTHER APPOINTMENT;3:PROVIDER WANTS ANOTHER APPOINTMENT;4:OTHER"
119 S DIR("L",1)="SELECT ONE OF THE FOLLOWING REASONS FOR # "_SDC_":",DIR("L",2)=""
120 S DIR("L",3)="1. APPOINTMENT CRITERIA NOT MET",DIR("L",4)="2. PATIENT WANTS ANOTHER APPOINTMENT"
121 S DIR("L",5)="3. PROVIDER WANTS ANOTHER APPOINTMENT",DIR("L,6")="4. OTHER"
122 S DIR("A")="Select one of the following reasons for #: "_SDC
123 D ^DIR
124 S X=$E(X,1,2) S:$E(X,2)'="R" X=$E(X)
125 S SDWLX=$S(X="a":"A",X="p":"P",X="pr":"PR",X="o":"O",X="A":"A",X="P":"P",X="PR":"PR",X="O":"O",X=1:"A",X=2:"P",X=3:"PR",X=4:"O",1:"^")
126 I SDWLX="^" Q
127 S SDR=1
128 I SDWLX="O" D
129 .S DIR(0)="FAO^^",DIR("A")="Comments: " D ^DIR Q:X["^"
130 .S SDWLCOM=X,DA=SDWLDA,DIE="^SDWL(409.3,",DR="18.1////^S X=SDWLCOM" D ^DIE
131 N DA S DA=SDWLDA
132 S DIE="^SDWL(409.3,",DR="18////^S X=SDWLX" D ^DIE
133 S DR="17////^S X=DUZ" D ^DIE
134 S DR="16////^S X=DT" D ^DIE
135 K SDWLERR,DIR,DR,DIE,X,SDWLX,SDWLDSS,SDWLASK,SDWLDA,SDWLCOM
136 K ^TMP($J,"SDWLPL",SDC)
137 Q
138HD ;HEADER
139 W:$D(IOF) @IOF W !!,?80-$L("Wait List - Disposition Patient")\2,"Wait List - Disposition Patient",!!
140 Q
141APPT(DFN,SD,SC) ;create appt TMP
142 ;SD - appt date/time
143 ;SC - clinic IEN
144 N SDARR,SCNT
145 S SDDIV=""
146 S SDARR(1)=SD_";"_SD
147 S SDARR(2)=SC
148 S SDARR(4)=DFN
149 S SDARR("FLDS")="1;2;3;4;10;13;14;17"
150 N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D
151 .N SDINST,SDFAC,SDINSTE
152 .Q:'$D(^TMP($J,"SDAMA301",DFN))
153 .S SCNT=$O(^TMP($J,"APPT",""),-1)+1
154 .S ^TMP($J,"APPT",SCNT)=^TMP($J,"SDAMA301",DFN,SC,SD)
155 .N SDCLIN S SDCLIN=$$CLIN^SDWLBACC(SC),SDINST=$P(SDCLIN,U),SDFAC=$P(SDCLIN,U,2),SDINSTE=$P(SDCLIN,U,3)
156 .S $P(^TMP($J,"APPT",SCNT),"^",15)=SDINST_";"_SDINSTE
157 .S $P(^TMP($J,"APPT",SCNT),"^",16)=SDFAC
158 .K ^TMP($J,"SDAMA301",DFN,SC,SD)
159 Q
160APPTD ;display appt
161 ;from ^TMP($J,"APPT")
162 N STR,SCNT
163 Q:'$D(^TMP($J,"APPT"))
164 S SCNT="" F S SCNT=$O(^TMP($J,"APPT",SCNT)) Q:SCNT="" D
165 .S STR=^TMP($J,"APPT",SCNT)
166 .N ZZ F ZZ=2,3,4,10,15 S SDD(ZZ)=$P($P(STR,"^",ZZ),";",2)
167 .N SD S SD=$P(STR,U) D S Y=SD D D^DIQ S SDD(1)=Y ; date conv
168 ..I SDD(3)="SCHEDULED/KEPT" S SDD(3)=";"_$S(SD<DT:"KEPT",1:"SCHEDULED")
169 .S SDD(16)=$P(STR,U,16)
170 .N CP,ZZ F ZZ=13,14 S CP(ZZ)=$P($P(STR,U,ZZ),";") D
171 ..S SDD(ZZ)=""
172 ..I CP(ZZ)>0 S SDD(ZZ)=$$GET1^DIQ(40.7,CP(ZZ)_",",.01,"I") ; stop code desc
173 .;DISPLAY
174 .I SCNT=1 D DPH(SCNT,.SDD)
175 .D DPHD(SCNT,.SDD)
176 W !
177 Q
178DATP(SCNT,SDA) ;
179 ;SDA - to return APPT array
180 S STR=^TMP($J,"APPT",SCNT)
181 S SDA(1)=$P(STR,U)
182 N ZZ F ZZ=2,3,10,13,14,15 S SDA(ZZ)=$P($P(STR,"^",ZZ),";",1)
183 S SDA(16)=$P(STR,"^",16) ;station
184 Q
185DPH(SCNT,SDD) ;display appt header
186 W !!,"Appointment(s) for: "_SDD(4) W !!?4,"Specialty: "_SDD(13),?60,"Station: ",SDD(16),!
187 W !?3,"Appt Date/Time",?23,"Clinic",?48,"Status",?60,"Institution",! N SDL S $P(SDL,"-",79)="" W SDL,!
188 Q
189DPHD(SCNT,SDD) ;
190 W !,SCNT,?3,SDD(1),?23,$E(SDD(2),1,23),?48,$E(SDD(10),1,10),?60,SDD(15)
191 Q
Note: See TracBrowser for help on using the repository browser.