source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLRP1.m@ 1314

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1SDWLRP1 ;;IOFO BAY PINES/TEH - WAITING LIST - RPC;06/28/2002 ; 26 Aug 2002 1:25 PM ; Compiled April 16, 2007 10:15:05
2 ;;5.3;scheduling;**263,273,485,497,446**;AUG 13 1993;Build 77
3 ;
4 ;
5 ;******************************************************************
6 ; CHANGE LOG
7 ;
8 ; DATE PATCH DESCRIPTION
9 ; ---- ----- -----------
10 ; 2/21/03 SD*5.3*273 Line new+12 added "/"
11 ; 5/10/06 SD*5.3*446 New field: INTRA-transfer
12OUTPUT(SDWLOUT,SDWLDFN) ;-FULL
13 ; input:
14 ; DFN = Patient
15 ; Lookup uses Wait List data file (409.3) and returns the following data.
16 ;
17 ; output:
18 ; SCOUT = location of data = ^TMP("SDWLG",$J,i,0)
19 ; for i=1:number of records returned:
20 ;
21 ; Field Location Description
22 ; 1 2 ORIGINATION DATE
23 ; 2 3 INSTITUTION
24 ; 3 4 CLINIC
25 ; 4 5 WAIT LIST TYPE
26 ; 5 6 SPECIFIC TEAM
27 ; 5.1 22 MARKED OPEN (SPECIFIC TEAM)
28 ; 6 7 SPECIFIC POSITION
29 ; 6.1 23 MARKED OPEN (SPEICIFIC POSITION)
30 ; 7 8 SERVICE /SPECIALTY
31 ; 8 9 SPECIFIC CLINIC
32 ; 9 10 ORIGINATING USER
33 ; 10 11 PRIORITY
34 ; 11 12 REQUESTED BY
35 ; 12 13 PROVIDER
36 ; 22 16 DESIRED DATE OF APPT
37 ; 23 17 CURRENT STATUS
38 ; 25 18 COMMENTS
39 ; 27 20 NEW ENROLLE
40 ;
41 N DIERR,SDWLDAX
42 I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=-1 Q ;- No Entry in Wait List file.
43 S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
44 .S SDWLDAX="`"_SDWLDA
45 .D FIND^DIC(409.3,,".01;1;2;3;4;5;5.1;6;6.1;7;8;9;10;11;12;15;22;23;25","PS",.SDWLDAX)
46 I $G(DIERR) D CLEAN^DILF S SDWLRES=-1 Q
47 K SDWLOUT S SDWLOUT=$NA(^TMP("DILIST",$J))
48 Q
49OUTPUT1(SDWLOUT,SDWLDFN) ;
50 ;Brief Output - for Wait List.
51 ; input:
52 ; DFN = Patient
53 ; Lookup uses Wait List data file (409.3) and returns the following data.
54 ;
55 ; output:
56 ; SWDLRES = On/Not on Wait list^Number of IENs^IEN;IEN;IEN;IEN.....
57 ; 1 0 ^ 2 ^1;2
58 ;
59 S SDWLCNT=0,SDWLIEN=""
60 I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=$NA(^TMP("SDWLRP1",$J)),^TMP("SDWLRP1",$J,1)=-1
61 S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
62 .I $P(^SDWL(409.3,SDWLDA,0),U,17)["C" Q
63 .S SDWLCNT=SDWLCNT+1
64 .S ^TMP("SDWLRP1",$J,SDWLCNT)=SDWLDA_"^"_$G(^SDWL(409.3,SDWLDA,0))
65 S SDWLOUT=$NA(^TMP("SDWLRP1",$J))
66 K SDWLDFN,SDWLDA,SDWLCNT,SDWLIEN
67 Q
68OUTPUT3(SDWLOUT,SDWLDFN) ;Disposition Data
69 ; input:
70 ; DFN = Patient Internal ID
71 ;
72 ; output: Subscript 'DIS'
73 ; Date Dsipositioned^Disposition by^Disposition
74 ;
75 N SDWLRES,SDWLDFN,SDWLDA,DIERR
76 I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=-1 Q ;- No Entry in Wait List file.
77 S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
78 .S SDWLDAX="`"_SDWLDA
79 .D FIND^DIC(409.3,,"19;20;21","PS",.SDWLDAX)
80 I $G(DIERR) D CLEAN^DILF S SDWLRES=-1 Q
81 K SDWLOUT S SDWLOUT="^TMP(""DILIST"","_$J_")",SDWLRES=1
82 Q
83INPUT(SDWLRES,SDWLSTR) ;
84 ; Input:
85 ; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
86 ; (R) = Required Field
87 ; (O) = Optional
88 ;
89 ; .01 2 3 5 6
90 ; DFN (R)^TYPE (R)^SPECIFIC TEAM (O)^SPECIFIC POSITION (O)^ORGINATING USER (R)^COMMENT (O)^CLINIC (O)^INTRA FLAG (O)^REJ FLAG (O)^MULTI TEAM FLAG (O)
91 ; 1 2 3 4 5 6 7 8 9 10
92 ;
93 ; Output:
94 ; SDWLRES = 0 Failed
95 ; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
96 ;
97 N DIERR,%H,SDWLF,SDWLFLD,SDWLFLG,SDWLI,SDWLIN,SDWLMSG,SDWLRNED,SDWLTP,SDWLVAL,SDWLX,SDWLY,X,Y
98 K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J),^TMP("DIERR",$J)
99 I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing" Q
100 D NEW
101 D FDA I SDWLRES<0 D DEL Q
102 ;D VAL I SDWLRES<0 D DEL Q
103 D SET I SDWLRES<0 D DEL Q
104 D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
105 K SDWLDUZ,SDWLDFN,SDWLDA,Y
106 Q
107NEW ;Get IEN from ^SDWL(409.3,IEN,0).
108 N DA,DIC,DIE,DIK,DR,SDREJ,SDINTRA,SDMULTI
109 I $P(SDWLSTR,U,4) D
110 .S SDWLTP=+$P(SDWLSTR,U,4)
111 .S SDWLIN=$P($G(^SCTM(404.51,+$P(^SCTM(404.57,SDWLTP,0),U,2),0)),U,7)
112 I $P(SDWLSTR,U,3) D
113 .S SDWLIN=$P($G(^SCTM(404.51,+$P(SDWLSTR,U,3),0)),U,7)
114 S SDWLDFN=+$P(SDWLSTR,U,1)
115 S SDREJ=$P(SDWLSTR,U,9),SDINTRA=$P(SDWLSTR,U,8),SDMULTI=$P(SDWLSTR,U,10)
116 ;identify INTRA-transfer
117 ;- last team assignment
118 S DIC(0)="LX",X=$P(SDWLSTR,U,1),DIC="^SDWL(409.3," D FILE^DICN I Y<0 S SDWLRES="-1^IEN failed" Q
119 S SDWLDFN=$P(Y,U,2),SDWLDA=+Y,SDWLDUZ=$P(SDWLSTR,U,9)
120 S DIE="^SDWL(409.3,",DA=SDWLDA
121 S DR="1///^S X=DT" D ^DIE
122 S DR="2////^S X=SDWLIN;32////^S X=SDREJ;34////^S X=SDINTRA;38////^S X=SDMULTI" D ^DIE
123 S DR="23///^S X=""O""",DIE="^SDWL(409.3," D ^DIE
124 ;
125 ;DETERMINE ENROLLEE STATUS
126 ;
127 ;SDWLE=1 = NEW ENROLLEE
128 ;SDWLE=2 = ESTABLISHED
129 ;SDWLE=3 = PRIOR ENROLLEE
130 ;SDWLE=4 = UNDETERMINED
131 ;
132 S SDWLDE=+$H,SDWLE=0,(SDWLEE,SDWLRNED,SDWLDB)=0 D SB1
133 G SB0:SDWLE=2
134 S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G SB0:$P(SDWLRNE,U,4)="A" S SDWLRNED=$P(SDWLRNE,U,3)
135 I SDWLRNED S X=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=+$H,SDWLDET=SDWLDE-SDWLDS,SDWLDB=2 I SDWLDET<366 S SDWLE=1
136 I $D(SDWLDET),SDWLDET>365 S SDWLE=3
137 I 'SDWLRNE S SDWLE=4
138SB0 I $D(SDWLRNE),$P(SDWLRNE,U,4)="A" D
139 .I 'SDWLRNE,SDWLEE>730!(SDWLEE=730) S SDWLE=4 Q
140 .I 'SDWLEE S SDWLE=4 Q
141 S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
142 ;-Code here for filling in 409.3
143 S DR="27////^S X=SDWLRNE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
144 S DR="9////^S X=DUZ" D ^DIE
145 S DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE
146 S DR="27.2////^S X=SDWLDB" D ^DIE
147 K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE
148 Q
149SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) N SDWLDB S SDWLE=3 Q
150 S SDWLX="" F S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX="" D
151 .S SDWLY=$G(^DGCN(391.91,SDWLX,0)) D
152 ..;CHECK FOR TREATING FACILITY
153 ..I $$TF^XUAF4(+$P(SDWLY,U,2)) D
154 ...;SORT FOR LAST TREATMENT DATE
155 ...S SDWLD=$P(SDWLY,U,3) I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
156 I '$D(SDWLDTF) Q
157 S SDWLDTF=$O(SDWLDTF(0)) I SDWLDTF S (SDWLD,X)=9999999-SDWLDTF D H^%DTC S SDWLEE=SDWLDE-%H,SDWLDB=1 I SDWLEE<730 S SDWLE=2
158 I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=3
159 K SDWLDTF
160 Q
161FDA ;Get data from SDWLSTR string and set FDA.
162 S SDWLF=409.3
163 S SDWLVAL="" F SDWLI=2:1:7 S SDWLVAL=$P(SDWLSTR,"^",SDWLI) D
164 .S SDWLFLD=SDWLI D
165 ..S SDWLFLD=$S(SDWLFLD=2:4,SDWLFLD=3:5,SDWLFLD=4:6,SDWLFLD=5:9,SDWLFLD=7:15,1:25)
166 .S SDWLFLG="F",SDWLIEN=$$IENS^DILF(SDWLDA) ;,SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
167 .I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
168 .D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
169 .S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
170 Q
171VAL ;Validate fields
172 N DIERR
173 D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
174 I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
175 M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
176 Q
177SET ;Input data to file ^SDWL(409.3,IEN,0).
178 D UPDATE^DIE(,"^TMP(""SDWLIN"",$J)","SDWLMSG")
179 I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
180 S SDWLRES=1_"^"_$G(SDWLDA)
181 Q
182DEL S DA=SDWLDA,DIK="^SDWL(409.3," D ^DIK
183 S SDWLRES="-1^Entry "_SDWLDA_" Deleted"
184 Q
185INPUTDP(SDWLRES,SDWLSTR) ;Set disposition in Wait List Patient file
186 ;
187 ; Input:
188 ;
189 ; SDWLSTR=Patient DFN^Disposition^User DUZ^Wait List IEN
190 ;
191 ; Ouput:
192 ;
193 ; SDWLRES=-1 Failed
194 ; SDWKRES=1^IEN for Wait List File (409.3)
195 ;
196 N SDWLDFN,SDWLDISP,SDWLDUZ,SDWLDA,SDWLDDT
197 I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing" Q
198 I '$G(^SDWL(409.3,SDWLDA,0)) S SDWLRES="-1^Missing Patient IEN" Q
199 I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES="-1^Missing Wait List data file" Q
200 D FDA1 I SDWLRES<0 D DEL1 Q
201 D VAL1 I SDWLRES<0 D DEL1 Q
202 D SET1 I SDWLRES<0 D DEL1 Q
203 D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
204 Q
205FDA1 ;
206 S SDWLDFN=$P(SDWLSTR,U,1),SDWLDISP=$P(SDWLSTR,U,2),SDWLDUZ=$P(SDWLSTR,U,3),SDWLDA=$P(SDWLSTR,U,4),SDWLDDT=DT
207 S SDWLIEN=$$IENS^DILF(SDWLDA)
208 F SDWLI=1:1:4 S SDWLVAL=$S(SDWLI=1:SDWLDISP,SDWLI=2:SDWLDUZ,SDWLI=3:SDWLDDT,SDWLI=4:"C"),SDWLFLD=$S(SDWLI=1:21,SDWLI=2:20,SDWLI=3:19,SDWLI=4:23) D
209 .S SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
210 .I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
211 .D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
212 .S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
213 Q
214VAL1 ;
215 N DIERR
216 D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
217 I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
218 M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
219 Q
220SET1 ;
221 D UPDATE^DIE(,"^TMP(""SDWLOUT"",$J)","SDWLMSG")
222 I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
223 S SDWLRES=1
224 Q
225DEL1 ;
226 S DA(1)=SDWLDA,DIK="^SDWL("_DA(1)_",""DIS""," F DA=19,20,21,23 D ^DIK
227 S SDWLRES="-1^"_"Disposition Nodes Deleted."
228 Q
Note: See TracBrowser for help on using the repository browser.