source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCCV.m@ 1267

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

initial load of FOIAVistA 6/30/08 version

File size: 8.4 KB
Line 
1SCMCCV ;ALB/REW - PCMM Conversion of Patient File Fields ; 1 Feb 1996
2 ;;5.3;Scheduling;**41**;AUG 13, 1993
3EN ;
4 ; Variables:
5 ; SCASSIGN: 1=Make Patient Assignments if unambiguous (0=No,default)
6 ; SCDT: Date to make assignments (Default=DT)
7 ; SCYESTM: 1=Make Pt Tm as well as Pt Posit Assmnts,default(0=No)
8 ; SCNOPRPT 1=Don't print patient-detail lines
9 ;
10 N SCOK,DFN,SCPCNODE,SCLIST,SCTMPLST,SCHISTAR,SCASSIGN,SCYESTM,SCTM,Y,SCSTOP,SCPAGE,SCNOPRPT,SCTEAMAR,SCNOW,SCSUB
11 N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
12 IF '$$OKASK D MESS("Search aborted","!?5") G QTEN
13 IF '$D(IO("Q")) D
14 .U IO
15 .D REP
16 .D ^%ZISC
17 ELSE D
18 .F X="SCASSIGN","SCYESTM","SCDT","SCNOPRPT" S ZTSAVE(X)=""
19 .S Y=$$QUE("SC Patient-Team/Practitioner"_$S('SCASSIGN:"Report Only",1:"Report and Assignment"),"REP^SCMCCV")
20QTEN Q
21 ;
22OKASK() ;
23 N SCOK,DIR
24 ;do you want to assign or just get a report?
25 S DIR(0)="Y"
26 S DIR("B")="NO"
27 S DIR("A")="Do you want to assign patients right now?"
28 S DIR("A",1)=""
29 S DIR("A",2)=""
30 S DIR("A",3)=" YES = Assign Patients to Teams and Team Positions"
31 S DIR("A",4)=" NO = Just print report to see how things would be"
32 D ^DIR
33 IF $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S SCOK=0 G QTASK
34 S SCASSIGN=Y
35 ;do you want to omit printing patients?
36 S DIR(0)="Y"
37 S DIR("B")="YES"
38 S DIR("A")="Do you want to omit printing patients?"
39 S DIR("A",1)=""
40 S DIR("A",2)=""
41 S DIR("A",3)=" NO = Print detail line for each patient that is assignable"
42 S DIR("A",4)=" YES = Just print Team & Practitioner information"
43 D ^DIR
44 IF $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S SCOK=0 G QTASK
45 S SCNOPRPT=Y
46 IF '$D(SCASSIGN) S SCASSIGN=0
47 IF '$D(SCDT) S SCDT=DT
48 IF '$D(SCYESTM) S SCYESTM=1
49 S SCOK=$$GETDEV
50QTASK Q SCOK
51 ;
52REP ;non-interactive portion
53 Q:$$FIRST^SCMCRU ;check for task end
54 IF '$$OKINIT() G QTEN
55 D MESS(" ..Ok")
56 IF '$$OKBUILD G QRP
57 D MESS(" ..Ok")
58 IF '$$OKREPORT G QRP
59 D MESS(" ..Ok")
60 IF '$$OKCLEAN G QRP
61 D MESS(" ..Ok")
62QRP Q
63 ;
64OKINIT() ;
65 N SCOK
66 S SCOK=1
67 D MESS(">>> Checking Programmer Variables:","!,?5")
68 IF +$G(DUZ)'>0!($G(U)'="^")!('$D(DT)) D Q 0
69 . S XPDABORT=1
70 . D MESS("You must first initialize Programmer Environment by running ^XUP")
71 . S SCOK=0
72 S SCLIST="SCTMPLST"
73 D INIT^SCAPMCU1(.SCOK)
74 D NOW^%DTC
75 S SCNOW=%
76 S SCHISTAR(.05)=1 ;pc practitioner
77 S SCHISTAR(.06)=DUZ ;user entering
78 S SCHISTAR(.07)=SCNOW ;date entered
79 S SCTEAMAR(.08)=1 ;pc team
80 S SCTEAMAR(.11)=DUZ ;user
81 S SCTEAMAR(.12)=SCNOW ;date enter=now
82 Q SCOK
83 ;
84OKBUILD() ;
85 N SCOK
86 S SCOK=1
87 D MESS(">>> Looping through PC Nodes of PATIENT File","!,?5")
88 S DFN=0
89 F S DFN=$O(^DPT(DFN)) Q:'DFN S SCPCNODE=$G(^DPT(DFN,"PC")) IF SCPCNODE]"" D D:'(DFN#100) MESS(".")
90 .S ^TMP("SCMC",$J,"TMPRPT",+$P(SCPCNODE,U,2),+$P(SCPCNODE,U,1),DFN)=""
91 Q SCOK
92 ;
93OKREPORT() ;
94 N SCOK,SCTM,SCPR,SCTMNODE
95 S SCOK=1
96 D MESS(">>> Producing PATIENT File PC Report","!?5")
97 D MESS(" Checking Team/Practitioner Assignments:","!?10")
98 S SCTM=0
99 F S SCTM=$O(^TMP("SCMC",$J,"TMPRPT",SCTM)) Q:'SCTM!$G(SCSTOP) D
100 .S SCTMNODE=$G(^SCTM(404.51,SCTM,0))
101 .D MESS(">>>Team: "_$$DISPTM(SCTM),"!!?10")
102 .IF '$$OKTEAM(SCTM,SCDT) D
103 ..S SCOK=0
104 ..;D MESS("Problem(s) with Practitioner Assignments","!?15")
105 Q SCOK
106 ;
107OKTEAM(SCTM,SCDT) ;return 1 if exactly 1 posit for each team assignment
108 ;needs 'tmp('scmc',$j,'tmpr' array defined
109 ;return count of positions pract is assigned to to team
110 N SCOK,SC200,SCTMND,SCFLD,SCF
111 S SCOK=1
112 S SCTMND=$G(^SCTM(404.51,+$G(SCTM),0))
113 F SCFLD=3,6,7 IF '$P(SCTMND,U,SCFLD) D ;check required fields
114 .S SCOK=0
115 .S SCF=$$DDNAME^SCMCRU(404.51,(SCFLD*.01))
116 .D MESS(SCF_" (#"_(SCFLD*.01)_") of Team required. Enter via PCMM ","!?20")
117 G:'SCOK QTOKTM
118 S SCOK=$$ACTTM^SCMCTMU(SCTM,SCDT)
119 IF 'SCOK D G QTOKTM
120 .N SCX
121 .S SCX=$D(^SCTM(404.58,SCTM,"AIDT",SCTM))
122 .D:'SCX MESS(" Never activated - Edit via PCMM")
123 .D:SCX MESS(" Not active on "_SCDT)
124 IF SCOK<0 D G QTOKTM
125 .D MESS(" Error in setup")
126 IF $D(^TMP("SCMC",$J,"TMPRPT",SCTM,0)) D
127 .D MESS("Team Assignment Only","!?15")
128 .D:'SCNOPRPT MESS("Patients to be assigned to this team:","!?20")
129 .S DFN=0 F S DFN=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,0,DFN)) Q:'DFN D
130 ..D MESS($$DISPPT(DFN),"!?25")
131 ..S SCX=$$NMPCTM^SCAPMCU2(DFN,SCDT,1)
132 ..D:SCX&(+SCX=SCTM)&('SCNOPRPT) MESS("Already assigned","!?27")
133 ..D:SCX&(+SCX'=SCTM)&('SCNOPRPT) MESS("Previously assigned to "_$P(SCX,U,2),"!?27")
134 ..Q:SCX
135 ..D:$G(SCASSIGN) PCUPDTM(DFN)
136 .D:$G(SCASSIGN) MAILLST^SCMCTMM(SCTM,"SCTEAMAR",SCDT,"^TMP(""SCMC"",$J,""NEWTM"",SCTM)")
137 .F SCSUB="NEWTM","BADTM" K ^TMP("SCMC",$J,SCSUB,SCTM)
138 S SC200=0
139 F S SC200=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,SC200)) Q:'SC200 D
140 .N SCTMPLST,SCCNT,SCTP,SCX,DFN
141 .D MESS("Practitioner: "_$$DISP200(SC200),"!?15")
142 .IF '$D(^VA(200,SC200,0)) D
143 ..S SCOK=0
144 ..D MESS("Bad Practitioner Assignment"_$S(SCNOPRPT:"",1:" for the following patient(s):"),"!?15")
145 ..S DFN=0 F S DFN=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,SC200,DFN)) Q:'DFN D
146 ...D MESS($$DISPPT(DFN),"!?25")
147 .ELSE D
148 .S:'$$TPPR^SCAPMC(SC200,"SCDTS",,,"SCTMPLST($J)",.SCERR) SCOK=0
149 .S SCXTP=0 F SCCNT=0:1 S SCXTP=$O(SCTMPLST($J,"SCTP",SCTM,SCXTP)) Q:'SCXTP S SCTP=SCXTP D MESS("Position: "_$$DISPTP(SCTP),"!?17")
150 .;if no team-position assignments for pract
151 .IF 'SCCNT D
152 ..S SCOK=0
153 ..D MESS("is assigned to "_SCCNT_" positions on team","!?20")
154 ..D MESS("you need to assign him/her to a position on the team","!?20")
155 ..S ^TMP("SCMC",$J,"NO_TP",SCTM,SC200)=""
156 .;if exactly one practitioner assignment to team
157 .IF SCCNT=1 D
158 ..D:'SCNOPRPT MESS("Patients to be assigned to this position:","!?20")
159 ..S DFN=0 F S DFN=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,SC200,DFN)) Q:'DFN D
160 ...D MESS($$DISPPT(DFN),"!?25")
161 ...S SCX=$$NMPCTP^SCAPMCU2(DFN,SCDT,1)
162 ...D:SCX&(+SCX=SCTP)&('SCNOPRPT) MESS("Already assigned","!?27")
163 ...D:SCX&(+SCX'=SCTP)&('SCNOPRPT) MESS("Previously assigned to "_$P(SCX,U,2),"!?27")
164 ...Q:SCX
165 ...D:$G(SCASSIGN) PCUPD(DFN)
166 ..D:$G(SCASSIGN) MAILLST^SCMCTPM(SCTP,"SCHISTAR",SCDT,"^TMP(""SCMC"",$J,""NEWTP"",SCTP)","^TMP(""SCMC"",$J,""OLDTP"",SCTP)","^TMP(""SCMC"",$J,""BADTP"",SCTP)")
167 ..D:$G(SCASSIGN) MAILLST^SCMCTMM(SCTM,"SCTEAMAR",SCDT,"^TMP(""SCMC"",$J,""NEWTM"",SCTM)")
168 ..F SCSUB="NEWTP","OLDTP","BADTP" K ^TMP("SCMC",$J,SCSUB,SCTP)
169 ..K ^TMP("SCMC",$J,"NEWTM",SCTM)
170 .;if multiple positin assignments for team for pract
171 .IF SCCNT>1 D
172 ..S SCOK=0
173 ..D MESS("Practitioner is assigned to "_SCCNT_" positions on team","!?20")
174 ..D MESS("because there is more than one position for this team","!?20")
175 ..D MESS("and practitioner, there will be no patient assignments","!?20")
176 ..S SCTP=0 F S SCTP=$O(SCTMPLST($J,SCTM,SCTP)) Q:'SCTP S ^TMP("SCMC",$J,"MULT_TP",SCTM,SC200,SCTP)=""
177 .IF SCCNT=1 S ^TMP("SCMC",$J,"ONE_TP",SCTM,SC200,SCTP)=""
178QTOKTM Q SCOK
179 ;
180PCUPD(DFN) ;
181 N SCX,SCNOMAIL
182 S SCNOMAIL=1
183 ;This is NOT a stand-alone procedure
184 S SCX=$$ACPTTP^SCAPMC(DFN,SCTP,"SCHISTAR",SCDT,.SCERR,SCYESTM)
185 IF SCX D
186 .D MESS("File #404.43 ien = "_+SCX,"!?30")
187 .IF $P(SCX,U,2) D
188 ..D MESS(" New Entry")
189 ..S ^TMP("SCMC",$J,"NEWTP",SCTP,DFN)=""
190 ..IF $P(SCX,U,4) D
191 ...D MESS(" Team Assignment Made. IEN="_$P(SCX,U,3),"!?30")
192 ...S ^TMP("SCMC",$J,"NEWTM",SCTM,DFN)=""
193 .ELSE D
194 ..D MESS(" Already Assigned")
195 ..S ^TMP("SCMC",$J,"OLDTP",SCTP,DFN)=""
196 ELSE D
197 .D MESS(" - NOT saved")
198 .S ^TMP("SCMC",$J,"BADTP",+$G(SCTP),DFN)=""
199 .D:('$P(SCX,U,2))&('$P(SCX,U,4))&('$P(SCX,U,3)) MESS("No Patient Team Assignment","!?30")
200 Q
201 ;
202PCUPDTM(DFN) ;
203 N SCX,SCNOMAIL
204 S SCNOMAIL=1
205 ;This is NOT a stand-alone procedure
206 S SCX=$$ACPTTM^SCAPMC(DFN,SCTM,"SCTEAMAR",SCDT,.SCERR)
207 IF SCX D
208 .D MESS("File #404.42 ien = "_+SCX,"!?30")
209 .IF $P(SCX,U,2) D
210 ..D MESS(" New Entry")
211 ..S ^TMP("SCMC",$J,"NEWTM",SCTM,DFN)=""
212 ELSE D
213 .D MESS(" - NOT saved")
214 .S ^TMP("SCMC",$J,"BADTM",+$G(SCTM),DFN)=""
215 Q
216 ;
217OKCLEAN() ;
218 D MESS(">>> Cleaning up ^TMP(""SCMC"" global","!?5")
219 N SCOK
220 S SCOK=1
221 ;K ^TMP("SCMC",$J)
222 Q SCOK
223 ;
224DISP200(SC200) ;
225 Q $P($G(^VA(200,SC200,0)),U,1)_" [#"_SC200_"]"
226 ;
227DISPTP(SCTP) ;
228 Q $P($G(^SCTM(404.57,SCTP,0)),U,1)_" [#"_SCTP_"]"
229 ;
230DISPTM(SCTM) ;
231 Q $P($G(^SCTM(404.51,SCTM,0)),U,1)_" [#"_SCTM_"]"
232 ;
233DISPPT(DFN) ;
234 Q $S(SCNOPRPT:"",1:$E($P($G(^DPT(DFN,0)),U,1),1,21)_" [SSN#:"_$P($G(^DPT(DFN,0)),U,9)_"]")
235 ;
236MESS(TEXT,FORMAT) ;
237 Q:$G(SCSTOP)!($G(TEXT)="")
238 S FORMAT=$G(FORMAT,"?5")
239 D OUT^SCMCRU(TEXT,FORMAT)
240 Q
241 ;
242GETDEV() ;
243 N SCOK
244 S SCOK=0
245 S %ZIS="PMQ" D ^%ZIS G:POP QTGDV
246 S SCOK=1
247QTGDV Q (SCOK)
248 ;
249QUE(NAME,START) ;
250 ; Needed: ZTSAVE array
251 ; NAME = description
252 ; START = starting point of routine
253 S ZTDESC=NAME,ZTRTN=START
254 D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK
255 D HOME^%ZIS K IO("Q")
256 Q ZTSK
Note: See TracBrowser for help on using the repository browser.