source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPM21U.m@ 975

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

initial load of WorldVistAEHR

File size: 9.0 KB
Line 
1SCRPM21U ;ALB/PDR - POSITION REASSIGNMENT UTILITIES ; AUG 1998
2 ;;5.3;Scheduling;**148,157**;Aug 13, 1993
3 ;
4PREVDAY(DAY) ; GET PREVIOUS DAY
5 N X,X1,X2
6 S X1=DAY,X2=-1
7 D C^%DTC
8 Q X
9 ;
10PCPCASN(FASIEN,SCTP) ; IS THIS A PRIMARY CARE to PRIMARY CARE ASSIGNMENT?
11 ; FASIEN = Pointer to source Position assignment SCPT(404.43)
12 ; SCTP = Destination position pointer to Position DEF file SCTM(404.57)
13 N SPPC,DPPC,STPC,SCST
14 ; Exclude the case where source = destination team
15 ;
16 S SCST=$P($G(^SCPT(404.43,FASIEN,0)),U,2) ; pointer to position DEF file
17 S SCST=$P($G(^SCTM(404.57,SCST,0)),U,2) ; pointer to team DEF file
18 I SCST="" Q 0 ; this is really an error condition
19 I SCST=$P($G(^SCTM(404.57,SCTP,0)),U,2) Q 0 ; source and dest teams are the same
20 ;
21 ; Both source and destination positions are (or will be) primary care.
22 ;
23 ; test source position is a pc position, and the new position is too
24 S SPPC=$P($G(^SCPT(404.43,FASIEN,0)),U,5)>0 ; source position is primary care
25 S DPPC=@SCFIELDA@(.05)>0 ; destination position is primary care
26 S STPC=$$GETPOSTM(FASIEN)
27 S STPC=$P($G(^SCPT(404.42,STPC,0)),U,8)=1 ; source team is primary care
28 ; if source pos and dest pos are PC OR source team and dest pos are PC then is a pc to pc assignment
29 Q (SPPC&DPPC)!(STPC&DPPC)
30 ;
31UPDATPOS(POSAIEN,SCERR) ; UPDATE EXISTING POSITION ASSIGNMENT PARAMETERS, AND ENSURE NO FUTURE DISCHARGE
32 N SC,SCFLD,ENTFLD
33 S ENTFLD=",.06,.07,"
34 S SC($J,404.43,(+POSAIEN)_",",.08)=DUZ ; last edited by
35 S SC($J,404.43,(+POSAIEN)_",",.09)=SCNOW ; last edit date/time
36 S SC($J,404.43,(+POSAIEN)_",",.03)=SCACT ; set new activity date for existing position assgn
37 S SC($J,404.43,(+POSAIEN)_",",.04)="" ; ensure no future discharge
38 IF $D(SCFIELDA) D
39 . S SCFLD=0
40 . F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
41 .. Q:ENTFLD[","_SCFLD_"," ; don't want ENTRY user and ENTRY date time for edit
42 .. S SC($J,404.43,(+POSAIEN)_",",SCFLD)=@SCFIELDA@(SCFLD)
43 D FILE^DIE("","SC($J)",SCERR) ; update position assignment paramaeters
44 I $D(@SCERR) S POSAIEN=0_U_POSAIEN
45 Q
46 ;
47TMEXIST(DFN,SCTM,SCSD,TMAIEN) ;
48 ; returns 1 if current/future assignment exists else 0
49 ; conserves IEN of the des tm asgn if it exists
50 N SCRESULT,SCSDT,SCX,SCTMLIST,SCTMERR
51 S (SCRESULT,TMAIEN)=0
52 ;
53 ;;set date variables for $$tmpt
54 S SCSDT("BEGIN")=$G(SCSD,DT)
55 S SCSDT("END")=$$FMADD^XLFDT(SCSDT("BEGIN"),36500)
56 ;
57 ;;look for current asgn first
58 S SCX=$$TMPT(1)
59 S TMAIEN=$O(SCTMLIST("SCTM",SCTM,0))
60 I +TMAIEN S SCRESULT=1 G TMXISTQ
61 ;
62 ;;look for nearest future legit asgn/dschrg
63 S SCX=$$TMPT(0)
64 I '+$O(SCTMLIST("SCTM",SCTM,0)) G TMXISTQ
65 ;
66 F S TMAIEN=$O(SCTMLIST("SCTM",SCTM,TMAIEN)) Q:'TMAIEN D
67 .S SCX=$O(SCTMLIST("SCTM",SCTM,TMAIEN,0))
68 .S SCX=$P(SCTMLIST(SCX),U,4,5)
69 .Q:$P(SCX,U,2)<+SCX
70 .S SCTMLIST("SCTM","BYDATE",+SCX,TMAIEN)=""
71 .Q
72 ;
73 S SCX=$O(SCTMLIST("SCTM","BYDATE",""))
74 I +SCX D
75 .S TMAIEN=$O(SCTMLIST("SCTM","BYDATE",SCX,""))
76 .S SCRESULT=1
77 .Q
78 ;
79TMXISTQ S TMAIEN=+TMAIEN
80 Q +SCRESULT
81 ;
82TMPT(SCX) ;
83 S SCSDT("INCL")=SCX
84 K SCTMLIST
85 K SCTMERR
86 Q $$TMPT^SCAPMC(DFN,"SCSDT","","SCTMLIST","SCTMERR")
87 ;
88DELPOS(DISIEN,POSAIEN) ; DELETE a position
89 ; DISIEN = SOURCE POSITION TO DISCHARGE
90 ; POSAIEN = CURRENT DESTINATION POSITION IEN - USED JUST AS AN ERROR INDICATOR HERE
91 S DIK="^SCPT(404.43,"
92 S DA=DISIEN
93 ;
94 IF DIK]"",$D(@(DIK_DA_",0)")) D ^DIK
95 E S POSAIEN=0_U_POSAIEN
96 Q
97 ;
98DISPOS(DISIEN,POSAIEN) ; DISCHARGE a position
99 ; DISIEN = SOURCE POSITION TO DISCHARGE
100 ; POSAIEN = CURRENT DESTINATION POSITION IEN - USED JUST AS AN ERROR INDICATOR HERE
101 N DISDAT
102 S DISDAT=SCACT ; init discharge date
103 I $P($G(^SCPT(404.43,DISIEN,0)),U,3)'>$$PREVDAY(SCACT) S DISDAT=$$PREVDAY(SCACT)
104 S STEC=$$INPTTP^SCAPMC(DFN,DISIEN,DISDAT,SCERR)
105 I 'STEC S POSAIEN=0_U_POSAIEN
106 Q
107 ;
108CREATPOS(POSAIEN,TMAIEN) ; CREATE A POSITION
109 N SCIEN
110 S POSAIEN="" ; initialize position IEN
111 IF $D(SCFIELDA) D
112 . S SCFLD=0
113 . F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
114 .. S SC($J,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
115 S SC($J,404.43,"+1,",.01)=TMAIEN
116 S SC($J,404.43,"+1,",.02)=SCTP
117 S SC($J,404.43,"+1,",.03)=SCACT
118 D UPDATE^DIE("","SC($J)","SCIEN",SCERR) ; create new position
119 IF $D(@SCERR) K SCIEN
120 ELSE D
121 . S POSAIEN=+$G(SCIEN(1))
122 . S SCNEWTP=1
123 . D AFTERTP^SCMCDD1(POSAIEN)
124 Q
125 ;
126DELTEAM(TMAIEN) ; DELETE A TEAM ASSIGNMENT
127 S DIK="^SCPT(404.42,"
128 S DA=TMAIEN
129 ;
130 IF DIK]"",$D(@(DIK_DA_",0)")) D ^DIK
131 E S TMAIEN=0_U_TMAIEN
132 Q
133 ;
134DISTEAM(TMAIEN) ; DISCHARGE A TEAM ASSIGNMENT
135 ; TMAIEN = SOURCE TEAM IEN
136 N DISDAT,SCPREVDT,SCNODE
137 S DISDAT=SCACT ; init discharge date
138 ; discharge for previous day if assignment date prior to today
139 I $P($G(^SCPT(404.42,TMAIEN,0)),U,9)'>$$PREVDAY(SCACT) S DISDAT=$$PREVDAY(SCACT)
140 N SCTEC
141 S SCTEC=$$INPTTM^SCAPMC(DFN,TMAIEN,DISDAT,SCERR) ; Discharge from team Assignments
142 I 'SCTEC S TMAIEN=0_U_TMAIEN
143 Q
144 ;
145CREATETM(DFN,SCTMTO,SCACT,TMAIEN) ; CREATE A TEAM ASSIGNMENT
146 N SCTM,SCIEN
147 S TMAIEN="+1,"
148 ; set team assignment type (i.e PC (1) or non-PC (99))
149 S:$D(@SCFIELDA@(.05)) SCTM($J,404.42,TMAIEN,.08)=$G(@SCMAINA@(.08),$S(@SCFIELDA@(.05):1,1:99))
150 ; set team user entering
151 S:$D(@SCFIELDA@(.06)) SCTM($J,404.42,TMAIEN,.11)=$G(@SCMAINA@(.11),@SCFIELDA@(.06))
152 ; set team Date/time entered
153 S:$D(@SCFIELDA@(.07)) SCTM($J,404.42,TMAIEN,.12)=$G(@SCMAINA@(.12),@SCFIELDA@(.07))
154 ; set team last edited by
155 ;S:$D(@SCFIELDA@(.08)) SCTM($J,404.42,TMAIEN,.13)=$G(@SCMAINA@(.13),@SCFIELDA@(.08))
156 ; set team date/time last edited
157 ;S:$D(@SCFIELDA@(.09)) SCTM($J,404.42,TMAIEN,.14)=$G(@SCMAINA@(.14),@SCFIELDA@(.09))
158 S SCTM($J,404.42,TMAIEN,.01)=DFN
159 S SCTM($J,404.42,TMAIEN,.02)=SCACT
160 S SCTM($J,404.42,TMAIEN,.03)=SCTMTO
161 D UPDATE^DIE("","SCTM($J)","SCIEN",SCERR) ; new entry
162 IF $D(@SCERR) D
163 . K SCIEN
164 . S TMAIEN=""
165 ELSE D
166 . S TMAIEN=$G(SCIEN(1)) ; new assignment record set up
167 . S SCNEWTM=1
168 . D AFTERTM^SCMCDD1(TMAIEN)
169 Q
170 ;
171TMACTIV(TMAIEN,PCPOS) ; CHANGE FUTURE ACTIVE DATE TO CURRENT DATE
172 ; PCPOS - flag that indicates whether or not team should be activated as a PC Team
173 ; the team definition is assumed to support PC service at this point
174 ; also remove future discharge date if present
175 S SC($J,404.42,(+TMAIEN)_",",.14)=SCNOW ; date time last edited
176 S SC($J,404.42,(+TMAIEN)_",",.13)=DUZ ; last edited by
177 S SC($J,404.42,(+TMAIEN)_",",.02)=SCACT ; assigned date
178 S SC($J,404.42,(+TMAIEN)_",",.09)="" ; discharge date
179 I PCPOS S SC($J,404.42,(+TMAIEN)_",",.08)=1 ;
180 D FILE^DIE("","SC($J)",SCERR) ; update TEAM assignment
181 I $D(@SCERR) S TMAIEN=0_U_TMAIEN
182 Q
183 ;
184XALLPOS(FASIEN,POSAIEN) ; DISCHARGE ALL POSITIONS FROM THE "from" TEAM
185 ; FASIEN = source position assignment IEN
186 ; POSAIEN = destination position assignment IEN, used just for error reporting here
187 ; this only occurs when the "from" pos and "to" pos are both Primary care,
188 ; or the "from" team is PC and the "to" pos is PC.
189 ; Rational is that a patient can't have more than one PC team
190 ;
191 ; use FASIEN to get team assignment, then find all positions for this team assignment,
192 ; and discharge them
193 N POSASGN,TMASGN,DISDAT,SCX,SCFLAG
194 S DISDAT=SCACT ; init discharge date
195 ; discharge for previous day if assignment date prior to today
196 S SCX=$$PREVDAY(SCACT)
197 I $P($G(^SCPT(404.43,FASIEN,0)),U,3)'>SCX S DISDAT=SCX
198 S SCFLAG=0
199 S TMASGN=+$P($G(^SCPT(404.43,FASIEN,0)),U,1)
200 I TMASGN D
201 .S POSASGN=0
202 .F S POSASGN=$O(^SCPT(404.43,"B",TMASGN,POSASGN)) Q:POSASGN="" D
203 ..S SCX=+$P($G(^SCPT(404.43,POSASGN,0)),U,4) ;already discharged?
204 ..I SCX,SCX<SCACT Q ;leave past alone!
205 ..K @SCERR
206 ..S STEC=$$INPTTP^SCAPMC(DFN,POSASGN,DISDAT,SCERR) ;discharge position
207 ..I $D(@SCERR) S SCFLAG=1
208 ..Q
209 .Q
210 I ('TMASGN)!(SCFLAG) S POSAIEN=0_U_POSAIEN
211 Q
212 ;
213GETPOSTM(POSAIEN) ; RETURN THE TEAM ASSIGNMENT FOR A POSITION
214 Q $P($G(^SCPT(404.43,POSAIEN,0)),U,1)
215 ;
216FUPOSASN(POSAIEN,SCACT) ; IS THIS A FUTURE POSITION ASSIGNMENT?
217 Q $P($G(^SCPT(404.43,POSAIEN,0)),U,3)>SCACT
218 ;
219FUTMASN(TMAIEN,SCACT) ; IS THIS A FUTURE TEAM ASSIGNMENT?
220 Q $P($G(^SCPT(404.42,TMAIEN,0)),U,2)>SCACT
221 ;
222FUTTMDIS(TMAIEN,SCACT) ; IS THERE A FUTURE TEAM DISCHARGE?
223 Q $P($G(^SCPT(404.42,TMAIEN,0)),U,9)>SCACT
224 ;
225DPOSPROB(SCPTTPA,SCACT) ; handle disposition of existing destination POSITION
226 I $$FUPOSASN(.SCPTTPA,SCACT) D Q:'SCPTTPA ; BAIL OUT
227 . D DELPOS(SCPTTPA,.SCPTTPA) ; DELETE future non-PC position assignment
228 . I 'SCPTTPA D ERROR^SCRPMPSP("Unable to DELETE non-PC position assignment for existing dest team",SCPTTPA,20) Q ; BAIL OUT
229 ELSE D
230 . D DISPOS(SCPTTPA,.SCPTTPA) ; else if current non-pc assignment discharge it
231 . I 'SCPTTPA D ERROR^SCRPMPSP("Unable to discharge non-PC position assignment with existing dest team",SCPTTPA,25) Q ; BAIL OUT
232 Q 'SCPTTPA
233 ;
234DTMPROB(SCPTTMA,SCACT) ; HANDLE DISPOSITION OF EXISTING DESTINATION TEAM
235 I $$FUTMASN(.SCPTTMA,SCACT) D Q:'SCPTTMA ; BAIL OUT
236 . D DELTEAM(.SCPTTMA) ; DELETE future dest NON-PC team assign
237 . I 'SCPTTMA D ERROR^SCRPMPSP("Unable to DELETE non-PC team assignment for existing dest team",SCPTTMA,30)
238 ELSE D
239 . D DISTEAM(.SCPTTMA) ; discharge current non-pc team assignment
240 . I 'SCPTTMA D ERROR^SCRPMPSP("Unable to discharge non-PC team assignment for existing dest team",SCPTTMA,35) Q ; BAIL OUT
241 Q 'SCPTTMA
Note: See TracBrowser for help on using the repository browser.