source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLQSC.m@ 1141

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

initial load of FOIAVistA 6/30/08 version

File size: 9.0 KB
Line 
1SDWLQSC ;IOFO BAY PINES/TEH,DMR - WAITING LIST-SC PRIORITY BACKGROUND ;09/02/2004 2:10 PM [4/21/05 8:04pm]
2 ;;5.3;scheduling;**327,394,467,446**;AUG 13, 1993;Build 77
3 ;
4 ;SD*5.3*327 EWL Updates Phase II - Addition of EWL notification messages.
5 ;SD*5.3*394 New Routine for background update of SDWL(409.3) SC priorities.
6 ;SD*5.3*467 Match canceled appts in 409.3
7 ;This routine will run as a background job to determine changes in SC disabilities and update
8 ;the priority of the wait list visit. A mailman message will then be sent to the EWL mail group.
9 ;Vars: SDWLDFN=EWL IEN
10 ; SDWLSC1=EWL RECORDED SC %
11 ; SDWLSC2=PATIENT FILE (2) CURRENT SC %
12 ;DBIAs: 1476 reference to PRIMARY ELIG. ^DPT(IEN,.372)
13 ; 427 reference to ^DIC(8)
14 Q
15EN ;Use SDWL(409.3) to determine SC changes and priority.
16 S SDWLDFN=0 F S SDWLDFN=$O(^SDWL(409.3,"B",SDWLDFN)) Q:SDWLDFN<1 D
17 .S SDWLDA=0,SDWLME=0 F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA="" D
18 ..L ^SDWL(409.3,SDWLDA):5 I '$T Q
19 ..I $P($G(^SDWL(409.3,SDWLDA,0)),U,17)["C" Q ;I EWL entry has been 'CLOSED' don't process.
20 ..S SDWLME=SDWLME+1
21 ..S SDWLSC1=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,1)
22 ..S SDWLSC2=+$$GET1^DIQ(2,SDWLDFN_",",.302,,"SDWLX","")
23 ..I SDWLSC1=SDWLSC2 S SDWLSC4=1 Q
24 ..S SDWLSCX=0,SDWLSC3=0,SDWLSC4=0
25 ..I SDWLSC2<50,SDWLSC1>49 D
26 ...S SDWLSC3=1,SDWLSC4=1,DA=SDWLDA,DR="14////^S X=SDWLSC2",DIE=409.3 D ^DIE,SET1
27 ..I SDWLSC2>49,SDWLSC1>49 S SDWLSCX=SDWLSC2 D SET0 Q
28 ..I SDWLSC2>49,SDWLSC1<50 S SDWLSCX=SDWLSC2 D SET0,SET1 Q
29 ..I SDWLSC2<50,SDWLSC1<50 S SDWLSC3=1,SDWLSC4=1,SDWLSCX=SDWLSC2 D SET0,SET1 Q
30 ..I '$D(^SDWL(409.3,SDWLDA,"SC")) D
31 ...I SDWLSC2>49 S SDWLSCX=SDWLSC2 D SET0,SET1 Q ;Set "SC" node if not defined.
32 ...I SDWLSC2<50 S SDWLSC3=1,SDWLSC4=1,DA=SDWLDA,DR="14////^S X=SDWLSC2",DIE=409.3 D ^DIE,SET1
33 ..K SDWLSSN,SDWLSC2,SDWLSC1,SDWLSC3,SDWLSCP,SDWLX,SDWLI,SDWLSCX
34 ..L Q
35 I $D(SDWLSC4),SDWLSC4 D
36 .I $D(^TMP("SDWLQSC2",$J)) D MESS1^SDWLMSG
37 I $D(^TMP("SDWLQSC1",$J)) D MESS^SDWLMSG
38 K SDWLDA,SDWLDFN,SDWLSC1,SDWLSC2,SDWLSC3,SDWLSC4,DA,DR,DIC,DIE,X,SDWLX,SDWLNAM,SDWLSSN,SDWLSCX,SDWLWRT,SDWLME
39 D EN2^SDWLQSC1 D EN3
40 K IEN,DFN,APPT,WLAPPT,STOP,WLSTAT,STATUS,NN,SDREC,SDARRAY,SDAPPT,CL,CLINIC,SDC,SDDFN,SDNAME,SDAPPST,CIEN,SDWL
41 K SDCL,SDIEN,CC,SDREACT,SDINACT,CLINICS,TEAM,TEAMN,WLOPEN,PIEN,POS,POSN,SDWLPOS,EDATE,DOD,DIS,NAME,MAX,AVAL,SDFORM
42 Q
43SET0 ;Set EWL file with current SC percentage.
44 S DA=SDWLDA,DR="14////^S X=SDWLSCX",DIE=409.3 D ^DIE
45 I SDWLSC2=50!(SDWLSC2>50) S DR="15////^S X=1" D ^DIE
46 K DA,DR,X,DIE
47 Q
48SET1 ;Set temporary file for message.
49 F SDWLI=.01,.09 S SDWLX(SDWLI)=$$GET1^DIQ(2,SDWLDFN_",",SDWLI,,"SDWLX","")
50 S SDWLNAM=$E($G(SDWLX(.01)),1,27),SDWLSSN=$E($G(SDWLX(.09)),6,99)
51 S SDWLSCP=$$GET1^DIQ(409.3,SDWLDA_",",15,,"SDWLSCP","")
52 S SDWLWRT=SDWLNAM,SDWLWRT=SDWLWRT_$J(SDWLSSN,(35-$L(SDWLNAM)))
53 S SDWLWRT=SDWLWRT_$J(SDWLSC1,8),SDWLWRT=SDWLWRT_$J(SDWLSC2,16-$L(SDWLSC1))
54 I 'SDWLSC3 S SDWLWRT=SDWLWRT_$J(SDWLSCP,15)
55 I SDWLSC3 S SDWLWRT=SDWLWRT_$J($S(SDWLME>1:"YES",1:"NO"),15)
56 I SDWLSC3 S ^TMP("SDWLQSC2",$J,SDWLDFN)=SDWLWRT Q
57 S ^TMP("SDWLQSC1",$J,SDWLDFN)=SDWLWRT
58 Q
59APPT(CLINIC,IEN) ;
60 S (SDREC,SDARRAY)=""
61 S SDARRAY(1)=WLAPPT_";"_WLAPPT
62 S SDARRAY(4)=DFN
63 S SDARRAY("FLDS")="3;2;4;1"
64 S SDREC=$$SDAPI^SDAMA301(.SDARRAY)
65 IF SDREC>0 D
66 .S (CL,SDC,SDDFN,SDNAM,SDAPPT,SDAPPST,NN)=""
67 .S CL=$O(^TMP($J,"SDAMA301",DFN,"")) Q:CL="" ;Current Clinic
68 .S SDAPPST=$P($G(^TMP($J,"SDAMA301",DFN,CL,WLAPPT)),"^",3),SDAPPST=$P(SDAPPST,";") ;Appt Status
69 .I CL'=CLINIC!(SDAPPST="CC") D
70 ..S SDDFN=$P($G(^TMP($J,"SDAMA301",DFN,CL,WLAPPT)),"^",4) IF SDDFN'="" S SDNAM=$P($G(SDDFN),";",2),SDNAM=$E(SDNAM,1,30)
71 ..S SDC=$P($G(^TMP($J,"SDAMA301",DFN,CL,WLAPPT)),"^",2)
72 ..S SDC=$$GET1^DIQ(44,CL_",",.01),SDC=$E(SDC,1,25)
73 ..S Y=WLAPPT D DD^%DT S SDAPPT=Y
74 ..IF CL'=CLINIC S SDC=SDC_"(new)" ;to distinguish another clinic"
75 ..S SDFORM=$$FORM^SDFORM(SDNAM,32,SDC,27,SDAPPT,21)
76 ..S NN=NN+1,^TMP("SDWLQSC3",$J,NN)=SDFORM
77 ..S DIE="^SDWL(409.3,",DA=IEN,DR="23////^S X=""O""" D ^DIE
78 ..S DR="13.8////^S X=""CC""" D ^DIE
79 ..S DR="29////^S X=""CA""" D ^DIE
80 ..S DR="19///@;20///@;21///@" D ^DIE
81 ..S DR="13///@;13.1////@;13.2///@;13.3///@;13.4///@;13.5///@;13.6///@;13.8///@;13.7///@" D ^DIE ;SD/467
82 Q
83EN3 ;Inactive clinics
84 S (CIEN,IEN,APPT,DFN,WLSTAT,SDCL,SDIEN,CC,SDREACT,SDINACT,CLINICS,SDFORM)=""
85 F S CIEN=$O(^SDWL(409.3,"SC",CIEN)) Q:CIEN<1 S CC=0 D
86 .S SDINACT=$$GET1^DIQ(44,CIEN_",",2505,"I"),SDREACT=$$GET1^DIQ(44,CIEN_",",2506,"I")
87 .Q:SDINACT=""&(SDREACT="") D
88 ..S IEN="" F S IEN=$O(^SDWL(409.3,"SC",CIEN,IEN)) Q:IEN<1 S WLSTAT=$$GET1^DIQ(409.3,IEN_",",23,"I") D
89 ...Q:WLSTAT'="O"
90 ...Q:SDINACT<SDREACT&((SDREACT+.01)>DT)
91 ...Q:SDINACT<DT&(SDREACT>SDINACT)
92 ...Q:SDINACT>(DT+.01)
93 ...S CC=CC+1
94 .IF CC>0 D
95 ..S CLINIC=$$GET1^DIQ(44,CIEN_",",.01),CLINIC=$E(CLINIC,1,30)
96 ..S SDFORM=$$FORM^SDFORM(CLINIC,40,CC,20),^TMP("SDWLQSC4",$J,CIEN)=SDFORM
97 ..S REC="",REC=$O(^SDWL(409.32,"B",CIEN,REC),-1)
98 ..IF REC'="" D
99 ...S SDINACT=$$GET1^DIQ(44,CIEN_",",2505,"I")
100 ...S DIE="^SDWL(409.32,",DA=REC,DR="3////^S X=SDINACT" D ^DIE
101 ...S DR="4////^S X=.5" D ^DIE
102 IF $D(^TMP("SDWLQSC4",$J)) D MESS3^SDWLMSG
103 D EN4
104 Q
105EN4 ;PCMM Team inactivated
106 S (IEN,TIEN,TEAM,TEAMN,DFN,CC,STATUS,WLOPEN,SDFORM)="" S CC="0"
107 F S TEAM=$O(^SDWL(409.3,"D",TEAM)) Q:TEAM<1 S CC=0 D
108 .S IEN="" F S IEN=$O(^SDWL(409.3,"D",TEAM,IEN)) Q:IEN<1 S WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I") D
109 ..Q:WLOPEN="C" S TIEN="",TIEN=$O(^SCTM(404.58,"B",TEAM,TIEN),-1) IF TIEN'="" D
110 ...S STATUS=$$GET1^DIQ(404.58,TIEN_",",.03,"I")
111 ...Q:STATUS="1"
112 ...IF STATUS="0" S CC=CC+1
113 .IF CC>0 D
114 ..S TEAMN=$$GET1^DIQ(404.51,TEAM_",",.01) S TEAMN=$E(TEAMN,1,30)
115 ..S SDFORM=$$FORM^SDFORM(TEAMN,40,CC,20),^TMP("SDWLQSC5",$J,TEAM)=SDFORM
116 IF $D(^TMP("SDWLQSC5",$J)) D MESS4^SDWLMSG
117 D EN5
118 Q
119EN5 ;PCMM Position inactivated
120 S (IEN,PIEN,POS,POSN,STATUS,WLOPEN,SDWLPOS,SDFORM,TEAM)=""
121 S SDWLPOS="" F S IEN=$O(^SDWL(409.3,"SP",IEN)) Q:IEN<1 D
122 .S POS="" F S POS=$O(^SDWL(409.3,"SP",IEN,POS)) Q:POS<1 D
123 ..S WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I")
124 ..Q:WLOPEN="C"
125 ..S PIEN="",PIEN=$O(^SCTM(404.59,"B",POS,PIEN),-1) IF PIEN'="" D
126 ... S POSN=$$GET1^DIQ(404.57,POS_",",.01)
127 ...IF PIEN'="" S STATUS=$$GET1^DIQ(404.59,PIEN_",",.03,"I")
128 ...Q:STATUS="1"
129 ...IF STATUS="0" D
130 ....S:'$D(SDWLPOS(POS)) SDWLPOS(POS)=0 S SDWLPOS(POS)=SDWLPOS(POS)+1,POSN=$E(POSN,1,30)
131 ....S TEAM=$$GET1^DIQ(404.57,POS_",",.02),TEAM=$E(TEAM,1,25)
132 ....S SDFORM=$$FORM^SDFORM(POSN,32,TEAM,27,SDWLPOS(POS),21)
133 ....S ^TMP("SDWLQSC6",$J,POS)=SDFORM
134 IF $D(^TMP("SDWLQSC6",$J)) D MESS5^SDWLMSG
135 D EN6
136 Q
137EN6 ;Date of Death
138 S (IEN,SDDFN,DIS,DOD,NAME)=""
139 F S SDDFN=$O(^SDWL(409.3,"B",SDDFN)) Q:SDDFN<1 D
140 .S IEN="" F S IEN=$O(^SDWL(409.3,"B",SDDFN,IEN)) Q:IEN<1 D
141 ..S DIS=$$GET1^DIQ(409.3,IEN_",",21,"I") IF DIS="D" D
142 ...S DOD=$$GET1^DIQ(2,SDDFN_",",.351) Q:DOD'="" D
143 ....S DIE="^SDWL(409.3,",DA=IEN,DR="23////^S X=""O""" D ^DIE
144 ....S DR="19///@" D ^DIE
145 ....S DR="20///@" D ^DIE
146 ....S DR="21///@" D ^DIE
147 ....S DR="29////^S X=""DE""" D ^DIE
148 ....S NAME=$$GET1^DIQ(2,SDDFN_",",.01) S ^TMP("SDWLQSC7",$J,SDDFN)=NAME
149 IF $D(^TMP("SDWLQSC7",$J)) D MESS6^SDWLMSG
150 D EN7
151 Q
152EN7 ;PCMM Team open slots
153 S (IEN,TIEN,TEAMN,CC,WLOPEN,MAX,AVAL,SDFORM,TEAM,STATUS)=""
154 F S TEAM=$O(^SDWL(409.3,"D",TEAM)) Q:TEAM<1 S CC=0 D
155 .S IEN="" F S IEN=$O(^SDWL(409.3,"D",TEAM,IEN)) Q:IEN<1 S WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I") D
156 ..Q:WLOPEN="C" S CC=CC+1
157 .IF CC>0 D
158 ..S TIEN="",TIEN=$O(^SCTM(404.58,"B",TEAM,TIEN),-1) IF TIEN'="" D
159 ...S STATUS=$$GET1^DIQ(404.58,TIEN_",",.03,"I")
160 ...Q:STATUS="0"
161 ...S MAX=$$GET1^DIQ(404.51,TEAM_",",.08)
162 ...S TEAMC=$$TEAMCNT^SCAPMCU1(TEAM,DT)
163 ...Q:(TEAMC+.01)>MAX S AVAL=MAX-TEAMC,TEAMN=$$GET1^DIQ(404.51,TEAM_",",.01)
164 ...S TEAMN=$E(TEAMN,1,30),SDFORM=$$FORM^SDFORM(TEAMN,35,AVAL,22,CC,12)
165 ...S ^TMP("SDWLQSC8",$J,TIEN)=SDFORM
166 IF $D(^TMP("SDWLQSC8",$J)) D
167 .S SDFORM=$$FORM^SDFORM("TEAM",35,"SLOTS AVAILIABLE",22,"EWL ENTRIES",12)
168 .S ^TMP("SDWLQSC8",$J,.06)=SDFORM
169 .D MESS7^SDWLMSG
170 D EN8
171 Q
172EN8 ;PCMM Position open slots
173 S (IEN,PIEN,POS,POSN,STATUS,WLOPEN,EDATE,SDWLPOS,SDWL,SDFORM)="" K SDWLPOS
174 S SDWLPOS="" F S IEN=$O(^SDWL(409.3,"SP",IEN)) Q:IEN<1 D
175 .S POS="" F S POS=$O(^SDWL(409.3,"SP",IEN,POS)) Q:POS<1 D
176 ..S PIEN="",PIEN=$O(^SCTM(404.59,"B",POS,PIEN),-1) IF PIEN'="" D
177 ...S STATUS=$$GET1^DIQ(404.59,PIEN_",",.03,"I")
178 ...S WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I"),EDATE=$$GET1^DIQ(404.59,PIEN_",",.02,"I")
179 ...Q:WLOPEN="C"
180 ...Q:((EDATE+.01)<DT&(STATUS="0"))
181 ...S:'$D(SDWLPOS(POS)) SDWLPOS(POS)=0 S SDWLPOS(POS)=SDWLPOS(POS)+1
182 S (IEN,POS,POSN,MAX,AVAL,CC,TEAM)=""
183 F S POS=$O(SDWLPOS(POS)) Q:POS<1 D
184 .S MAX=$$GET1^DIQ(404.57,POS_",",.08),SDWL=$$PCPOSCNT^SCAPMCU1(POS,DT)
185 .Q:(SDWL+.01)>MAX
186 .S TEAM=$$GET1^DIQ(404.57,POS_",",.02),TEAM=$E(TEAM,1,23)
187 .S AVAL=MAX-SDWL,POSN=$$GET1^DIQ(404.57,POS_",",.01)
188 .S POSN=$E(POSN,1,23),SDFORM=$$FORM^SDFORM(POSN,25,TEAM,25,AVAL,14,SDWLPOS(POS),11)
189 .S ^TMP("SDWLQSC9",$J,POS)=SDFORM
190 IF $D(^TMP("SDWLQSC9",$J)) D
191 .S SDFORM=$$FORM^SDFORM("POSITION",25,"TEAM",25,"SLOTS AVAIL",14,"EWL ENTRIES",11)
192 .S ^TMP("SDWLQSC9",$J,.06)=SDFORM
193 .D MESS8^SDWLMSG
194 Q
Note: See TracBrowser for help on using the repository browser.