source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPMPSP.m@ 1683

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1SCRPMPSP ;ALB/PDR - Team APIs:ACPTTP ; AUG 1998
2 ;;5.3;Scheduling;**148,157,169,177**;AUG 13, 1993
3 ;
4ACPTTP(DFN,SCTP,SCFIELDA,SCACT,FASIEN,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
5 ; input:
6 ; DFN = pointer to PATIENT file (#2)
7 ; SCTP = pointer to TEAM POSTION file (#404.57) (DESTINATION POSITION)
8 ; SCFIELDA= array of extra field entries - scfielda('fld#')=value for 404.43
9 ; SCACT = date to activate [default=DT]
10 ; FASIEN = "FROM" position assignment IEN
11 ; SCERR = array NAME to store error messages.
12 ; [ex. ^TMP("ORXX",$J)]
13 ; SCYESTM = Should team assignment be made, if none active now?[1=YES]
14 ; SCMAINA= array of extra field entries for 404.42
15 ;
16 ; Output:
17 ; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
18 ; SCERR() = Array of DIALOG file messages(errors) .
19 ; Foramt:
20 ; Subscript: Sequential # from 1 to n
21 ; Piece Description
22 ; 1 IEN of DIALOG file
23 N SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCST,PATH
24 N SCPTTPA,SCTMFLDA,SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS
25 N SCLOCK,SCXLOCK,SCX
26 ;
27 ;
28 I '$$OKDATA D ERROR(1,FASIEN,5) G APTTPQ
29 ;
30 I '$D(^XTMP("SCMC POS REASGN")) D
31 . S ^XTMP("SCMC POS REASGN",0)=DT_U_DT_U_"POS REASGN PROCESS LOCK"
32 . Q
33 ;
34 S SCXLOCK=0
35 S SCLOCK="^XTMP(""SCMC POS REASGN"",DFN)"
36 I $D(@SCLOCK) D ERROR(10,FASIEN,7) G APTTPQ
37 S @SCLOCK=""
38 S SCXLOCK=1
39 H 1
40 ;
41 ;
42 D INITVARS
43 I '$$GETPLST D ERROR(2,FASIEN,10) G APTTPQ
44 ;
45 ;bp/cmf 177 new begin
46 S SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
47 I SCX<1 D ERROR($P(SCX,U,2),FASIEN,11) G APTTPQ
48 ;bp/cmf 177 new end
49 ;
50 ; Business rule processing
51 ;
52 ; case 1
53 I $$POSEXIST(.SCTM,SCTP,.SCPTTPA,.SCPTTMA) D D SETP(1) G APTTPQ
54 . ; destin pos asgn exists
55 . I '$$PCPCASN^SCRPM21U(FASIEN,SCTP) D D SETP(1.1) Q
56 .. ; not PC to PC pos reasgn
57 .. ;
58 .. ; update pos asgn
59 .. D UPDATPOS^SCRPM21U(.SCPTTPA,SCERR)
60 .. I 'SCPTTPA D ERROR(3,SCPTTPA,12) Q
61 .. ;
62 .. ; update tm asgn
63 .. I $$FUTMASN^SCRPM21U(SCPTTMA,SCACT)!$$FUTTMDIS^SCRPM21U(.SCPTTMA,SCACT) D Q:'SCPTTMA
64 ... D TMACTIV^SCRPM21U(.SCPTTMA,$$PCPOS)
65 ... I 'SCPTTMA D ERROR(4,SCPTTMA,20)
66 ... Q
67 .. ;
68 .. ; dschrg source pos
69 .. D DISPOS^SCRPM21U(FASIEN,.SCPTTPA)
70 .. I 'SCPTTPA D ERROR(5,SCPTTPA,30)
71 .. Q
72 . ;
73 . ; PC to PC pos reasgn
74 . N SCFLAG
75 . S SCFLAG=0
76 . N SCY
77 . S SCY=0
78 . F S SCY=$O(SCAPTTPO("SCTP",SCTM,SCTP,SCY)) Q:'SCY!(SCFLAG) D
79 .. S SCPTTPA=SCY
80 .. S SCPTTMA=$$GETPOSTM^SCRPM21U(SCPTTPA)
81 .. I '$D(^SCPT(404.43,SCPTTPA)) Q
82 .. S SCFLAG=$$DPOSPROB^SCRPM21U(SCPTTPA,SCACT)
83 .. I SCFLAG Q
84 .. I '$D(^SCPT(404.42,SCPTTMA)) Q
85 .. S SCFLAG=$$DTMPROB^SCRPM21U(SCPTTMA,SCACT)
86 .. Q
87 . Q:SCFLAG
88 . ;
89 . ; create new destin tm, pos asgns
90 . D CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
91 . I 'SCPTTMA D ERROR(6,SCPTTMA,40) Q
92 . D CREATPOS^SCRPM21U(.SCPTTPA,SCPTTMA)
93 . I 'SCPTTPA D ERROR(7,SCPTTPA,50) Q
94 . ;
95 . ; take care of source bookkeeping
96 . D XALLPOS^SCRPM21U(FASIEN,.SCPTTPA)
97 . I 'SCPTTMA D ERROR(8,SCPTTMA,60) Q
98 . D DISTEAM^SCRPM21U($$SRCTEAM)
99 . I 'SCPTTPA D ERROR(9,SCST,70) Q
100 . Q
101 ;
102 ; case 2
103 I $$TMEXIST^SCRPM21U(DFN,SCTM,SCACT,.SCPTTMA) D D SETP(2) G APTTPQ
104 . ; destin tm asgn exists
105 . I $$PCPCASN^SCRPM21U(FASIEN,SCTP) D D SETP(2.1) Q
106 .. ; PC to PC tm reassgn
107 .. ;
108 .. ; take care of destin bookkeeping
109 .. Q:$$DTMPROB^SCRPM21U(SCPTTMA,SCACT)
110 .. ;
111 .. ; create new destin tm, pos asgns
112 .. D CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
113 .. I 'SCPTTMA D ERROR(6,SCPTTMA,80) Q
114 .. D CREATPOS^SCRPM21U(.SCPTTPA,.SCPTTMA)
115 .. I 'SCPTTPA D ERROR(7,SCPTTPA,100) Q
116 .. ;
117 .. ; take care of source bookkeeping
118 .. D XALLPOS^SCRPM21U(FASIEN,.SCPTTPA)
119 .. I 'SCPTTMA D ERROR(8,SCPTTMA,105) Q
120 .. D DISTEAM^SCRPM21U($$SRCTEAM)
121 .. I 'SCPTTPA D ERROR(9,SCST,107) Q
122 .. Q
123 . ;
124 . ;not PC to PC tm reassgn
125 . ; update tm asgn
126 . I $$FUTMASN^SCRPM21U(.SCPTTMA,SCACT)!$$FUTTMDIS^SCRPM21U(.SCPTTMA,SCACT) D Q:'SCPTTMA
127 .. D TMACTIV^SCRPM21U(.SCPTTMA,$$PCPOS)
128 .. I 'SCPTTMA D ERROR(4,SCPTTMA,120)
129 .. Q
130 . ;
131 . ; create pos asgn
132 . D CREATPOS^SCRPM21U(.SCPTTPA,.SCPTTMA)
133 . I 'SCPTTPA D ERROR(7,SCPTTPA,130)
134 . ;
135 . ; dschrg source pos
136 . D DISPOS^SCRPM21U(FASIEN,.SCPTTPA)
137 . I 'SCPTTPA D ERROR(5,SCPTTPA,135)
138 . Q
139 ;
140 ; case 3
141 ; no destin asgn
142 I $$PCPCASN^SCRPM21U(FASIEN,SCTP) D D SETP(3.1) G APTTPQ
143 . ; PC to PC reasgn
144 . ;
145 . ; create new destin tm, pos asgns
146 . D CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
147 . I 'SCPTTMA D ERROR(6,SCPTTMA,140) Q
148 . D CREATPOS^SCRPM21U(.SCPTTPA,SCPTTMA)
149 . I 'SCPTTPA D ERROR(7,SCPTTPA,160) Q
150 . ;
151 . ; take care of source bookkeeping
152 . D XALLPOS^SCRPM21U(FASIEN,.SCPTTPA)
153 . I 'SCPTTPA D ERROR(8,SCPTTMA,180) Q
154 . D DISTEAM^SCRPM21U($$SRCTEAM)
155 . I 'SCPTTPA D ERROR(9,SCST,185) Q
156 . Q
157 ;
158 D SETP(3)
159 ; not PC to PC reasgn
160 ;
161 ; create new destin tm, pos asgns
162 D CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
163 I 'SCPTTMA D ERROR(6,SCPTTMA,187) G APTTPQ
164 D CREATPOS^SCRPM21U(.SCPTTPA,SCPTTMA)
165 I 'SCPTTPA D ERROR(7,SCPTTPA,190) G APTTPQ
166 ;
167 ; dschrg source pos
168 D DISPOS^SCRPM21U(FASIEN,.SCPTTPA)
169 I 'SCPTTPA D ERROR(5,SCPTTPA,200)
170 ;
171APTTPQ ; All done
172 D SAVPARMS
173 I SCXLOCK=1 K @SCLOCK
174 Q +$G(SCPTTPA)_U_+$G(SCNEWTP)_U_+$G(SCPTTMA)_U_+$P($G(SCPTTMA),U,2)_U_$G(SCMESS)
175 ;
176 ;
177OKDATA() ;setup/check variables
178 N SCOK
179 S SCOK=1
180 D INIT^SCAPMCU1(.SCOK)
181 IF '$D(^DPT(DFN,0))!('$D(^SCTM(404.57,SCTPTO,0))) D S SCOK=0
182 . S SCPARM("PATIENT")=DFN
183 . S SCPARM("POSITION")=SCTPTO
184 . D ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",SCERR)
185 S:'$G(SCACT) SCACT=DT
186 S:'$D(SCMAINA) SCMAINA="SC40443A"
187 Q SCOK
188 ;
189INITVARS ; INITIALIZE LOCAL VARIABLES
190 S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2) ; destin tm ien
191 S SCAPTDT("BEGIN")=SCACT
192 S SCAPTDT("END")=3990101
193 S SCAPTDT("INCL")=0
194 S SCST=$$GETPOSTM^SCRPM21U(FASIEN) ; source tm ien
195 S SCPTTMA=""
196 S SCMESS=""
197 K @SCERR
198 Q
199 ;
200GETPLST() ; get patient position list
201 Q $$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE")
202 ;
203POSEXIST(SCTM,SCTP,POSAIEN,TMIEN) ;
204 ; if active pos asgn, return ien
205 N DISDT,SCX,SCY,SCFLAG
206 S TMIEN=""
207 S SCTM=+$P($G(^SCTM(404.57,SCTP,0)),U,2) ;ptr to 404.51
208 ;
209 S SCFLAG=0
210 S POSAIEN=0
211 ;
212 S SCX=0
213 F S SCX=$O(SCAPTTPO("SCTP",SCTM,SCTP,SCX)) Q:'SCX!(SCFLAG) D
214 . S SCY=$O(SCAPTTPO("SCTP",SCTM,SCTP,SCX,0))
215 . S DISDT=$P(SCAPTTPO(SCY),U,6)
216 . I DISDT=SCACT Q ;pos is discharged
217 . S TMIEN=$$GETPOSTM^SCRPM21U(SCX) ; tm asgn ien
218 . S DISDT=$P($G(^SCPT(404.42,TMIEN,0)),U,9)
219 . I DISDT,DISDT'>SCACT Q ;tm is discharged
220 . S SCFLAG=1
221 . S POSAIEN=SCX
222 . Q
223 ;
224 I SCFLAG Q POSAIEN
225 Q 0_U_$O(SCAPTTPO("SCTP",SCTM,SCTP,0))
226 ;
227ERROR(TXT,IEN,ENUM) ; HANDLE ERRORS FOR REPORTING
228 I +TXT S TXT=$P($T(T+TXT),";;",2)
229 S SCMESS=" "_TXT_" [E#"_ENUM_"]"
230 ; NVS - use below for more detailed ien and path data
231 ;I $P(IEN,U,1)=0 S IEN=$P(IEN,U,2)
232 ;S SCMESS=TXT_" [(IEN="_IEN_") E#"_ENUM_" PTH:"_$G(PATH)_"]"
233 ;S ^TMP("PDR",$J,"POSREASGN",$H,DFN)=SCMESS
234 Q
235 ;
236T ;;
2371 ;;Data Integrity error.;;
2382 ;;Unable to get positions list.;;
2393 ;;Unable to activate existing position.;;
2404 ;;Unable to activate existing team.;;
2415 ;;Unable to discharge source position.;;
2426 ;;Unable to create destination team.;;
2437 ;;Unable to create destination position.;;
2448 ;;Unable to discharge all positions for PC source team.;;
2459 ;;Unable to discharge PC source team.;;
24610 ;;Patient is being reassigned by another PCMM process.;;
247 ;;
248 ;
249SAVPARMS ; save params for debugging
250 ; NVS - comment out the quit to save path/variable data
251 Q
252 N S,F,NVP
253 S S=""
254 S S=$O(^TMP("PDR",S),-1)+1 ; get next occurence
255 S ^TMP("PDR",S,$J,"INIT")=DFN_U_SCTP_U_SCACT_U_FASIEN_U_SCYESTM ; initial params passed in
256 S F="",NVP=""
257 F S F=$O(@SCFIELDA@(F)) Q:F="" S NVP=NVP_F_"="_@SCFIELDA@(F)_U ; Get the params passed in for new pos
258 S ^TMP("PDR",S,$J,"NPOS")=NVP
259 S F="",NVP=""
260 F S F=$O(@SCMAINA@(F)) Q:F="" S NVP=NVP_F_"="_@SCFIELDA@(F)_U ; Get the params passed in for new TEAM
261 S ^TMP("PDR",S,$J,"NTEAM")=NVP
262 S ^TMP("PDR",S,$J,"NASSGN")=$G(SCPTTPA)_U_$G(SCPTTMA)_U_$G(PATH)_U_$G(SCMESS)_U_$H ; conserve new pos and team assigns if present
263 Q
264 ;
265SETP(BR) ; SET PATH INDICATOR FOR DEBUGGING
266 ; NVS - comment out the quit to save path/variable data
267 Q
268 S PATH=$G(PATH)_BR_"-"
269 Q
270 ;
271SRCTEAM() ; return source tm ien
272 ; value set in INITVARS
273 Q SCST
274 ;
275DSTTEAM() ; return destin tm ien
276 Q SCTM
277 ;
278PCPOS() ; IS THIS A PC POSITION?
279 Q $G(@SCFIELDA@(.05),0)
280 ;
Note: See TracBrowser for help on using the repository browser.