source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m@ 699

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

revised back to 6/30/08 version

File size: 9.5 KB
Line 
1SCMCQK1 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 07 Oct 2002 12:10 PM ; Compiled April 12, 2007 10:03:59
2 ;;5.3;Scheduling;**148,177,231,264,436,297,446**;AUG 13, 1993;Build 77
3 ;
4 ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER
5UNTP ;unassign patient from pc prac position
6 I '$G(SCTP) W !,"No position defined" Q
7 N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
8 S OK=0
9 W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"
10 S SCDISCH=$$DATE("D")
11 G:SCDISCH<1 QTUNTP
12 G:'$$CONFIRM() QTUNTP
13 S OK=1 ;$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
14 G:OK'>0 QTUNTP
15 S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
16 I SCCL D DISCL
17QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.")
18 Q
19ENRCL ;
20 N SCRESTA,SCREST,SCCLNM,SCTM
21 N SCCL
22 F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D
23 .Q:$$ACTCL(DFN,SCCL)
24 .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic."
25 .;SCRESTA = Array of pt's teams causing restricted consults
26 .N SCRESTA
27 .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA")
28 .I SCREST D
29 ..N SCTM
30 ..S SCCLNM=Y
31 ..W !,?5,"Patient has restricted consults due to team assignment(s):"
32 ..S SCTM=0
33 ..F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM)
34 .I SCREST&'$G(SCOKCONS) D G QTECL
35 ..W !,?5,"This patient may only be enrolled in clinics via"
36 ..W !,?15,"Edit Clinic Enrollment Data option"
37 .W !,"Do you wish to enroll the patient from this clinic on "
38 .S Y=SCASSDT X ^DD("DD") W Y,"?"
39 .I $$YESNO() D
40 ..W !,"Clinic Enrollment"
41 ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made"
42 ..E W "NOT made"
43QTECL Q
44DISCL ;
45 N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D
46 .Q:'$$ACTCL(DFN,SCCL)
47 .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic."
48 .W !,"Do you wish to discharge the patient from this clinic on "
49 .S Y=SCDISCH X ^DD("DD") W Y,"?"
50 .Q:'$$YESNO()
51 .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL
52 .N DFN D ^SDCD
53QTDCL Q
54UNTM ;
55 ;assign patient from pc team (and pc position if possible)
56 N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3
57 S OK=0
58 W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"
59 W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]"
60 S SCDISCH=$$DATE("D")
61 G:SCDISCH<1 QTUNTM
62 G:'$$CONFIRM() QTUNTM
63 IF 'SCTPSTAT D G:OK2'>0 QTUNTM
64 .W !,"PC assignment unassigned."
65 .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
66 .IF OK2>0 D
67 ..W "made."
68 ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9)
69 ..D:SCCL DISCL
70 S OK3=$$ALLPOS()
71 IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D
72 .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)
73 ELSE D
74 .W !,"Future/Current Patient-Position Assignment exists"
75QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.")
76 Q
77ALLPOS() ;unassign all patient-positions for team
78 ;not stand-alone - needs dfn,sctm
79 ;return 1=No positions left assigned|0=At least 1 position assigned
80 N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2
81 S SCDT1("BEGIN")=SCDISCH+1
82 S SCDT1("END")=3990101
83 S SCDT1("INCL")=0 ;anytime from now to future
84 S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR)
85 S (SCTP,SCCNT)=0
86 W !,"Checking for other position assignments to team..."
87 F S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP S SCCNT=SCCNT+1 D
88 .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1)
89 .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0))
90 .S SCNODE=SCPTTPX(SCLOC)
91 .S SCPTTP2(SCTP)=""
92 .W !,?3,$P(SCNODE,U,2)," ",$P(SCNODE,U,8)
93 .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D
94 ..W !,?5,"Unassignment date already exists or unassignment after assignment date"
95 ..W !,?15,"- Correct via PCMM GUI"
96 ..S OK=0
97 W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)"
98 G:'OK!('SCCNT) QTALL
99 W !!,"About to unassign the above patient-position assignments"
100 IF '$$CONFIRM S OK=0 G QTALL
101 S SCTP=0
102 F S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP D Q:'OK
103 .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
104 .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI"
105QTALL Q OK
106ASTM ;assign patient to PC team
107 N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
108 S OK=0
109 W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team"
110 I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
111 S DIC="^SCTM(404.51,"
112 S DIC(0)="AEMQZ"
113 S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
114 ;select from active teams that can be PC Teams
115 D ^DIC
116 G:Y<1 QTASTM
117 S SCTM=+Y
118 ;The following logic to present warning message added per SD*5.3*436
119 I $P($G(^SCTM(404.51,SCTM,0)),U,10) D G:'SCFLAG QTASTM
120 .S SCFLAG=0
121 .W !!,"This team is closed to further patient assignments. While you are"
122 .W !,"not currently prevented from assigning this patient, you may want to"
123 .W !,"check before continuing."
124 .Q:'$$YESNO1() ; new function call per SD*5.3*436
125 .Q:'$$CONFIRM()
126 .S SCFLAG=1 W !
127 S SCASSDT=$$DATE("A")
128 G:SCASSDT<1 QTASTM
129 S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)
130 S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8)
131 I SCTMCT'<SCTMMAX D G QTASTM:$$WAITYN(),QTASTM:'$$YESNO2()
132 .W !,"This assignment will reach or exceeded the maximum set for this team."
133 .W !,"Currently assigned: "_SCTMCT
134 .W !,"Maximum set for team: "_SCTMMAX
135 I SCTMCT<SCTMMAX,'$$CONFIRM() G QTASTM
136 S SCTM=+Y
137 ;setup fields
138 S SCTMFLDS(.08)=1 ;primary care assignment
139 S SCTMFLDS(.11)=$G(DUZ,.5)
140 D NOW^%DTC S SCTMFLDS(.12)=%
141 IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME") D
142 .S SCSELECT=$$SELPOS()
143 .D:$L(SCSELECT) ASTP ;prompt for position prompt
144 .S OK=1
145QTASTM W !,"Team Assignment "_$S(OK:"made",1:"NOT made.")
146 S:$D(SDWLPCMM) SDWLPCMM=OK ; 446
147 Q
148ASTP ;assign patient to PC practitioner
149 N DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
150 S OK=0
151 W !!,"About to Assign "_$$NAME(DFN)_" to PC Position Assignment"
152 I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
153 ;lookup to display only position and [practitioner]
154 IF SCSELECT="PRACT" D
155 .S DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W "" ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]"""
156 .S DIC("A")="POSITION's Current PRACTITIONER: "
157 .S DIC="^SCTM(404.52,"
158 .;Must be from team, must be activation,must not have future inactivation
159 .S DIC("S")="I $$PRACSCR^SCMCQK1(Y)"
160 .S D="C"
161 ELSE D
162 .S DIC="^SCTM(404.57,"
163 .S D="B"
164 .S DIC("A")="POSITION's Name: "
165 .S DIC("S")="I $$POSSCR^SCMCQK1(Y)"
166 S DIC(0)="AEMQZ"
167 D MIX^DIC1
168 G:Y<1 QTASTP
169 IF SCSELECT="PRACT" D
170 .S SCTP=$P(Y,U,2)
171 ELSE D
172 .S SCTP=$P(Y,U,1)
173 S SCASSDT=$$DATE("A")
174 G:SCASSDT<1 QTASTP
175 S SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP),SCTMMAX=+$P($G(^SCTM(404.57,SCTP,0)),U,8)
176 I SCTMCT'<SCTMMAX D G QTASTP:$$WAITYN,QTASTP:'$$YESNO2
177 .W !,"This assignment will reach or exceeded the maximum set for this position."
178 .W !,"Currently assigned: "_SCTMCT
179 .W !,"Maximum set for position: "_SCTMMAX
180 G:'$$CONFIRM() QTASTP
181 ;setup fields
182 S SCTPFLDS(.03)=SCASSDT
183 S SCTPFLDS(.05)=1 ;pc pract role
184 S SCTPFLDS(.06)=$G(DUZ,.5)
185 D NOW^%DTC S SCTPFLDS(.07)=%
186 IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0) D
187 .S OK=1
188 .S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,0))
189 .D:SCCL ENRCL
190QTASTP W !,"Position Assignment "_$S(OK:"made",1:"NOT made.")
191 S:$D(SDWLPCMM) SDWLPCMM=OK ;446
192 Q
193NAME(DFN) ;return patient name
194 Q $P($G(^DPT(DFN,0)),U,1)
195POSITION(SCTP) ;return position name
196 Q $P($G(^SCTM(404.57,SCTP,0)),U,1)
197TEAMNM(SCTM) ;return team name
198 Q $P($G(^SCTM(404.51,SCTM,0)),U,1)
199CLINIC(SCCL) ;return clinic name
200 Q $P($G(^SC(+SCCL,0)),U,1)
201YESNO() ;
202 N DIR,X,Y
203 S DIR(0)="Y",DIR("B")="YES"
204 D ^DIR
205 Q Y>0
206YESNO1() ; added per SD*5.3*436
207 N DIR,X,Y
208 S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?"
209 S DIR("B")="NO"
210 D ^DIR
211 Q Y>0
212YESNO2() ;
213 N DIR,X,Y
214 S DIR(0)="Y",DIR("B")="NO"
215 S DIR("A")="Do you wish to continue with the assignment (Yes/No)?"
216 D ^DIR
217 Q Y>0
218CONFIRM() ;confirmation call
219 N DIR,X,Y
220 S DIR("A")="Are you sure (Yes/No)"
221 S DIR(0)="Y"
222 D ^DIR
223 Q +Y=1
224SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE
225 N DIR,X,Y
226 W !,"Choose way to select PC POSITION Assignment: "
227 S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"
228 S DIR("B")=1
229 D ^DIR
230 Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT")
231DATE(TYPE) ;return date type=A or D
232 N DIR,X,Y
233 S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: "
234 S DIR(0)="DA^::EXP"
235 S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")
236 X ^DD("DD")
237 S DIR("B")=Y
238 D ^DIR
239 Q Y
240ACTCL(DFN,SCCL) ;is patient enrolled in clinic?
241 N SCXX
242 S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1)
243 Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1)
244PRACSCR(SC40452) ;screen for for file 404.52
245 N SCP,SCNODE,OK
246 S SCP=$G(^SCTM(404.52,SC40452,0))
247 S OK=0
248 G:'SCP QTPP
249 S SCNODE=$G(^SCTM(404.57,+SCP,0))
250 S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0)
251QTPP Q OK
252POSSCR(SCTP) ;screen for file 404.57
253 N SCNODE
254 S SCNODE=$G(^SCTM(404.57,SCTP,0))
255 Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)
256 Q
257WAITYN() ;
258 N %,OK,Y
259 I SCTMCT<SCTMMAX Q 0
260 N A,SC S A=$$ONWAIT^SCMCWAIT(DFN) I A W:(+A=3) !,$P(A,";",2) I $S($G(SCTP):A>1,1:1) Q 0
261 N DIR,X,Y
262 S DIR(0)="Y",DIR("B")="NO"
263 S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?"
264 D ^DIR
265 I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List"
266 Q Y>0
267SC(DFN) ;Is patient 50 to 100%
268 D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49
Note: See TracBrowser for help on using the repository browser.