source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLREB.m@ 1235

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1SDWLREB ;BP/ESW - EWL matched with Canceled and Rebooked Appointment by Clinic ; 11/16/05 1:16pm
2 ;;5.3;Scheduling;**467**;Aug 13, 1993
3 ;
4 ;SD*5.3*467 - Match canceled appointments in EWL entries
5 ;
6 Q
7REBOOK(DFN,SD,SC,RBFLG,SDTRB,SDCAN) ; rebook section
8 ;create appt TMP to check for rebooking
9 ;SD - appt date/time
10 ;SC - Hospital Location IEN
11 ;called by reference:
12 ; RBFLG - cancellation status from Appointment Multiple
13 ; Only if RBFLG="CCR" - canceled by clinic, rebooked
14 ; SDTRB - asked for scheduled Date/Time of Rebooked Appointment
15 ; SDCAN - asked for cancellation date/time
16 N SDARR,SCNT
17 S RBFLG=0,SDTRB="",SDCAN="NONE" ;initiate if not 'good' appointment
18 S SDARR(1)=SD_";"_SD
19 S SDARR(2)=SC
20 S SDARR(4)=DFN
21 S SDARR("FLDS")="1;2;3;24;25"
22 N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D
23 .N SDINST,SDFAC,SDINSTE
24 .Q:'$D(^TMP($J,"SDAMA301",DFN))
25 .N SDSTR S SDSTR=^TMP($J,"SDAMA301",DFN,SC,SD)
26 .N SDSTAT S SDSTAT=$P(SDSTR,U,3)
27 .K ^TMP($J,"SDAMA301",DFN,SC,SD)
28 .S RBFLG=$P(SDSTAT,";")
29 .S SDTRB=$P(SDSTR,U,24)
30 .S SDCAN=$P(SDSTR,U,25)
31 Q
32DISREB(DFN,SDTRB,SC) ;DISPOSITION REBOOK OR NOT
33 ; DFN - IEN of file #2 (Patient)
34 ; SDTRB - Scheduled Date/Time of Rebooked Appt
35 ; SC - Clinic IEN
36 ; Temporary ^TMP($J,"APPT" will be created with rebooked appt data
37 N SDARR,SCNT
38 S SDDIV=""
39 S SDARR(1)=SDTRB_";"_SDTRB
40 S SDARR(2)=SC
41 S SDARR(4)=DFN
42 S SDARR("FLDS")="1;2;3;4;10;13;14"
43 N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D
44 .N SDINST,SDFAC,SDINSTE
45 .Q:'$D(^TMP($J,"SDAMA301",DFN))
46 .K ^TMP($J,"APPT") S SCNT=1
47 .S ^TMP($J,"APPT",SCNT)=^TMP($J,"SDAMA301",DFN,SC,SDTRB)
48 .S SDINST=$$GET1^DIQ(44,SC_",",3,"I") ; get Institution
49 .S SDINSTE=$$GET1^DIQ(44,SC_",",3,"E")
50 .S SDFAC=$S(SDINST="":"",1:$$GET1^DIQ(4,SDINST_",",99,"I")) ; Station
51 .I SDFAC="" N SDDIV S SDDIV="" S SDDIV=$$GET1^DIQ(44,SC_",",3.5,"I") D
52 ..I SDDIV'="" S SDINST=$$GET1^DIQ(40.8,SDDIV_",",.07,"I") I SDINST'="" D
53 ...S SDFAC=$S(SDINST="":"",1:$$GET1^DIQ(4,SDINST_",",99,"I")) ; Station
54 ..I SDDIV="" S SDFAC=$P($$SITE^VASITE(,),"^",3)
55 .S $P(^TMP($J,"APPT",SCNT),"^",15)=SDINST_";"_SDINSTE
56 .S $P(^TMP($J,"APPT",SCNT),"^",16)=SDFAC
57 .K ^TMP($J,"SDAMA301",DFN,SC,SDTRB)
58 Q
59OPENEWL(DFN,SDT,SC,SDREB,CEWL) ; SD*5.3*467 Open EWL entry if closed with appointment being canceled
60 ;SDT - appointment date/time
61 ;SC - appointment clinic IEN
62 ;SDREB - REBOOKING FLAG: 1 - cancel & rebook
63 ; 0 - cancel only
64 ;CEWL - counter, optionally passed by reference with initial value=0
65 N DH,IEN,STATUS,CLINIC,WLAPPT,WLSTAT,SDNAM,SDAPPT,SSN,SCN
66 K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
67 I '$D(CEWL) D
68 .I $D(^TMP("SDWLREB",$J)) S CEWL=$O(^TMP("SDWLREB",$J,""),-1)
69 .E S CEWL=0
70 S IEN="" F S IEN=$O(^SDWL(409.3,"B",DFN,IEN)) Q:IEN<1 D
71 .S STATUS="" S STATUS=$$GET1^DIQ(409.3,IEN_",",23,"I") IF STATUS="C" D
72 ..IF $G(^SDWL(409.3,IEN,"SDAPT")) D
73 ...S CLINIC=$$GET1^DIQ(409.3,IEN_",",13.2,"I"),WLAPPT=$$GET1^DIQ(409.3,IEN_",",13,"I")
74 ...IF CLINIC=SC&(WLAPPT=SDT) S WLSTAT=$$GET1^DIQ(409.3,IEN_",",21,"I") I WLSTAT="SA" D
75 ....N Y S Y=WLAPPT D DD^%DT S SDAPPT=Y
76 ....S SCN=$$GET1^DIQ(44,SC_",",.01),SCN=$E(SCN,1,20)
77 ....S SDNAM=$$GET1^DIQ(2,DFN_",",.01,"I"),SDNAM=$E(SDNAM,1,25),SSN=$$GET1^DIQ(2,DFN_",",.09,"I")
78 ....S SDFORM=$$FORM^SDFORM(SDNAM,23,SSN,12,SCN,24,SDAPPT,20)
79 ....S CEWL=CEWL+1 S ^TMP("SDWLREB",$J,CEWL)=SDFORM
80 ....N DIE,DA,DR
81 ....S DIE="^SDWL(409.3,",DA=IEN,DR="23////^S X=""O""" D ^DIE
82 ....S DR="13.8////^S X=""CC""" D ^DIE
83 ....S DR="29////^S X=""CA""" D ^DIE
84 ....S DR="19///@" D ^DIE
85 ....S DR="20///@" D ^DIE
86 ....S DR="21///@" D ^DIE
87 ....S DR="13///@;13.1////@;13.2///@;13.3///@;13.4///@;13.5///@;13.6///@;13.8///@;13.7///@" D ^DIE
88 ....I $D(^TMP("SDWLREB",$J)) I SDREB D ASKDISP(IEN)
89 I '$D(^TMP($J,"SDWLPL")) Q ; no closed EWL related entry
90 I SDREB D DISP
91 Q
92MESS ; SD*5.3*467 - send message with a list of opened EWL entries because of canceled appointments
93 S ^TMP("SDWLREB",$J,.01)="This message displays patients that had their EWL entry opened because of "
94 S ^TMP("SDWLREB",$J,.02)="their matching appointment being now 'CANCELED BY CLINIC'. Some of those "
95 S ^TMP("SDWLREB",$J,.03)="entries may be already closed again if new appointments were scheduled and "
96 S ^TMP("SDWLREB",$J,.04)="matched with those EWL entries. You may use 'SD WAIT LIST REOPEN ENTRIES' "
97 S ^TMP("SDWLREB",$J,.05)="to run report identifying the related EWL entries."
98 N SDFORM S SDFORM=$$FORM^SDFORM("PATIENT NAME",23,"SSN",12,"CLINIC",24,"DATE/TIME of APPT",20) D ;added
99 .S ^TMP("SDWLREB",$J,.06)=SDFORM
100 S ^TMP("SDWLREB",$J,.07)="-----------------------------------------------------------------------"
101 S ^TMP("SDWLREB",$J,.08)=""
102 N XMSUB,XMY,XMTEXT,XMDUZ
103 S XMSUB="EWL opened entries with appointments 'CANCELED BY CLINIC'."
104 S XMY("G.SD EWL BACKGROUND UPDATE")=""
105 S XMTEXT="^TMP(""SDWLREB"",$J,"
106 S XMDUZ="POSTMASTER"
107 D ^XMD K ^TMP("SDWLREB",$J)
108 Q
109ASKDISP(IEN) ;
110 ;IEN - pointer to 409.3 to get data and display
111 N SDDIS S SDDIS=0 ; flag indicating disposition
112 W ! N X,DIR,DENTER
113 Q:$$GET1^DIQ(409.3,IEN_",",23,"I")="C"
114 S ^TMP("SDWLPL",$J,IEN)=$G(^SDWL(409.3,IEN,0)) S DENTER="",DENTER=$P($G(^TMP("SDWLPL",$J,IEN)),"^",2)
115 S (WLTYPE,TYPE,WLTN,NUM)="",TYPE=$P($G(^TMP("SDWLPL",$J,IEN)),"^",5)
116 IF DENTER'=""&(TYPE'="") D
117 .IF TYPE=1 S WLTYPE="PCMM TEAM",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",6),WLTNI=$$GET1^DIQ(404.51,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.51,NUM_",",.01)
118 .IF TYPE=2 S WLTYPE="PCMM POSITION",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",7),WLTNI=$$GET1^DIQ(404.57,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.57,NUM_",",.01)
119 .IF TYPE=3 S WLTYPE="SERV/SPECIALTY",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
120 .IF TYPE=4 S WLTYPE="CLINIC",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
121 E Q
122 D SAVE(TYPE,WLTNI,IEN)
123 Q
124SAVE(TYPE,WLTNI,IEN) ;
125 ;TYPE - EWL type
126 ;WLTNI - TYPE related name the EWL entry is waiting for
127 ;IEN - pointer to 409.3
128 S REQBY=$P($G(^TMP("SDWLPL",$J,IEN)),"^",12)
129 S INST=$P($G(^TMP("SDWLPL",$J,IEN)),"^",3)
130 N DESIRED S DESIRED=$P($G(^TMP("SDWLPL",$J,IEN)),"^",16)
131 N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09)
132 N SDBY S SDBY=$$GET1^DIQ(409.3,IEN_",",11),SDBY=$E(SDBY,1,3)
133 S NN=$O(^TMP($J,"SDWLPL",""),-1)+1
134 S ^TMP($J,"SDWLPL",NN)=IEN_U_WLTYPE_U_U_WLTN_U_INST_U_DENTER_U_SDBY_U_DESIRED
135 ;
136 N SPIEC S SPIEC=$S(TYPE=4:9,TYPE=3:10,TYPE=2:11,TYPE=1:12)
137 S $P(^TMP($J,"SDWLPL",NN),U,SPIEC)=WLTNI
138 K ^TMP("SDWLPL",$J,IEN)
139 Q
140DISP ;
141 W !,"EWL Entry has just been opened because of its matching appointment",!,"being canceled.",!!
142 N DIR S DIR("B")="YES" ; default to match and close rebooked appointments
143 S DIR("A")="Do you wish to close this EWL entry with Rebooked Appointment(Yes/No)",DIR(0)="Y"
144 W "Closing this entry will disposition it: SA - REMOVED/SCHEDULED-ASSIGNED",!,"with Rebooked Appointment.",!!
145 S DIR("?")="Y(ES) will disposition this EWL entry as 'SA' with just rebooked appointment."
146 D LIST ; disable displaying EWL entry per SRS.
147 W ! D ^DIR
148 N SDDIS S SDDIS=0 I Y S SDDIS=1
149 E Q
150 N SDWLDISP,SDWLDA,SDWLDFN,NUM
151 I SDDIS S SDWLDISP="SA",NUM="" F S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM="" S REC=^TMP($J,"SDWLPL",NUM) D
152 .S SDWLDA=+REC N SDP,SDR D
153 .S DIE="^SDWL(409.3,",DA=SDWLDA,DR="21////^S X=SDWLDISP" D ^DIE
154 .S DR="19////^S X=DT" D ^DIE
155 .S DR="20////^S X=DUZ" D ^DIE
156 .S DR="23////^S X=""C""" D ^DIE
157 .;I SDWLDISP="SA" update with appointment data
158 .;get appointment data to file (for a particular appt #)
159 .I SDWLDISP="SA" N SDA D DATP^SDWLEVAL(1,.SDA) D
160 ..I $D(SDA) S DIE="^SDWL(409.3,",DA=SDWLDA D
161 ...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
162 ...D ^DIE
163 .N SDWLSCL,SDWLSS,SDC
164 .S SDC=1
165 .S SDWLSCL=$P($G(^TMP($J,"SDWLPL",SDC)),U,9)
166 .S SDWLSS=$P($G(^TMP($J,"SDWLPL",SDC)),U,10)
167 .I SDWLSCL K:$D(^SDWL(409.3,"SC",SDWLSCL,SDWLDA)) ^SDWL(409.3,"SC",SDWLSCL,SDWLDA)
168 .S SDWLDFN=$P($G(^TMP($J,"APPT",1)),U,4)
169 .I SDWLSS,SDWLDFN K:$D(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)) ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)
170 Q
171LIST ;LIST
172 ;may be called if EWL entry display would be needed
173 S (REC,NUM)="" N SDPN
174 F S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM="" S REC=^TMP($J,"SDWLPL",NUM) D
175 .S IEN=+REC N SDP,SDR D
176 ..S SDPN=$$GET1^DIQ(409.3,IEN_",",.01) W !,"Patient: ",SDPN
177 ..W !," EW List Type P Waiting for Institution Orig Date By Des. Date Reopen"
178 ..W !,"--------------------------------------------------------------------------"
179 ..S SDP=$E($$GET1^DIQ(409.3,IEN_",",10)) ;priority
180 ..S SDR=$$GET1^DIQ(409.3,IEN_",",29,"I") ;reopen reason
181 .N SDINS,SDIN S SDINS=$P(REC,"^",5) S SDIN=$$GET1^DIQ(4,SDINS_",",.01,"I")
182 .W !,NUM_". ",$E($P(REC,"^",2),1,12),?17,SDP,?21,$E($P(REC,U,4),1,13),?35,SDIN,?45,$$FMTE^XLFDT($P(REC,"^",6),8),?57,$P(REC,"^",7),?61,$$FMTE^XLFDT($P(REC,"^",8),8),?76,SDR
183 .N SDUP,SDLO
184 .S SDUP="ABCDEFGHIJKLMNOPRSTUWQXYzv",SDLO="abcdefghijklmnoprstuwqxyzv"
185 .N SMT S SMT=$$GET1^DIQ(409.3,IEN_",",25) I SMT'="" S SMT=$TR(SMT,SDUP,SDLO) W !?2,"Comment: ",SMT
186 .N SMO S SMO=$$GET1^DIQ(409.3,IEN_",",30) I SMO'="" S SMO=$TR(SMO,SDUP,SDLO) W !?2,"Reopen: ",SMO
187 K ANS1,NN,INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI
188 K CLINIC,WLTYPE,TYPE,WLTN,NUM,REC
189 Q
Note: See TracBrowser for help on using the repository browser.