source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPMTA.m@ 703

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

initial load of WorldVistAEHR
File size: 9.1 KB
RevLine 
[613]1SCRPMTA ;ALB/REW/PDR - Team Reassignment APIs:APPTTM ; AUG 1998
2 ;;5.3;scheduling;**148,157**;aug 13, 1993
3 ; Reassign patient Team, called from RPC ='SC FILE PAT TM REASGN' (PTFILE^SCMRBK - PTFILE^SCMRBK)
4 ;
5 ;;1.0
6 ; MAKE A SINGLE PATIENT TEAM REASSIGNMENT
7ACPTTM(DFN,SCTMTO,SCFIELDA,SCACT,FASIEN,SCERR) ;add a patient to a team (pt tmassgn - #404.42)
8 ; input:
9 ; DFN = pointer to PATIENT file (#2)
10 ; SCTMTO = pointer to TEAM file (#404.51) "TO" Team
11 ; SCFIELDA= array of additional fields to be added for 404.42
12 ; SCACT = date to activate [default=DT]
13 ; FASIEN = IEN of source team assignment
14 ; SCERR = array NAME to store error messages.
15 ; [ex. ^TMP("ORXX",$J)]
16 ;
17 ; Output:
18 ; Returned = ien of 404.42 - 0 if none after^new?^Message
19 ; SCERR() = Array of DIALOG file messages(errors) .
20 ; Foramt:
21 ; Subscript: Sequential # from 1 to n
22 ; Piece Description
23 ; 1 IEN of DIALOG file
24 N SCPTTM,SCESEQ,SCPARM,SCIEN,SC,SCFLD,SCNEWTM,SCDTPAR,SCMESS
25 ;
26 ;
27 I '$$OKDATA D G APTTMQ ;check/setup variables
28 . D ERROR("Failed initial data check","",10)
29 ;
30 ; PROCESS REASSIGNMENT
31 ; get destination team assignment parameters if already existing assignment
32 I '$$GETTMPAR(DFN,SCTMTO,SCACT,.SCERR,.SCDTPAR,.SCPTTM) D G APTTMQ ; BAIL if error
33 . D ERROR("Unable to get list of team assignments for patient",FASIEN,20)
34 ; Make sure this reassignment doesn't set up more than 1 primary care team for PT
35 I $$INVALMOV(SCPTTM,FASIEN,SCDTPAR) D G APTTMQ ; BAIL if error
36 . D ERROR("Patient already has a primary care assignment",FASIEN,30)
37 ;
38 ; check for currently active destination assignment and discharge if so
39 I $$ACTIVDES(SCDTPAR,SCACT) D G:SCPTTM APTTMQ ; BAIL OUT if discharge unsuccessfull
40 . I $$DISTMOK(DFN,SCPTTM,SCACT,DUZ,"Destination") S SCPTTM="" Q ; going to create a new team
41 . D ERROR("Unable to discharge current destination assignment",SCPTTM,40)
42 ;
43 ; discharge source team
44 I '$$DISTMOK(DFN,FASIEN,SCACT,DUZ,"Source") D G APTTMQ
45 . ; error messages setup within call to DISTMOK
46 . S SCPTTM=""
47 ;
48 ; Move the patient to destination team and create destination team if necessary
49 I '$$MOVPATOK(DFN,SCACT,SCTMTO,SCFIELDA,SCDTPAR,.SCPTTM,DUZ) D G APTTMQ
50 . D ERROR("Unable to move patient to destination team",FASIEN,50)
51 ;
52APTTMQ ;
53 ;B
54 Q +$G(SCPTTM)_U_+$G(SCNEWTM)_U_$G(SCMESS)
55 ;
56 ;-------------------- SUBS -------------------------------
57 ;
58PTTMACT(DFN,SCTMTO,SCDT,SCERR) ;what is patient/team assignment on a given date-time into the future? Return 404.42 ien or 0
59 N SCTMLST,SCOK,SCPTTMDT
60 S SCOK=0
61 S SCPTTMDT("BEGIN")=SCDT,SCPTTMDT("END")=3990101,SCPTTMDT("INCL")=0
62 IF $$TMPT^SCAPMC3(DFN,"SCPTTMDT","","SCTMLST",.SCERR) S:$D(SCTMLST("SCTM",SCTMTO)) SCOK=$O(SCTMLST("SCTM",SCTMTO,0))
63 Q SCOK
64 ;
65OKDATA() ;setup/check variables
66 N SCOK
67 S SCOK=1
68 D INIT^SCAPMCU1(.SCOK)
69 IF '$D(^DPT(DFN,0))!('$D(^SCTM(404.51,SCTMTO,0))) D S SCOK=0
70 . S SCPARM("PATIENT")=DFN
71 . S SCPARM("TEAM")=SCTMTO
72 . D ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
73 S:'$G(SCACT) SCACT=DT
74 Q SCOK
75 ;
76DISTMOK(DFN,TMIEN,SCACT,SCDUZ,SD) ; Discharge patient from Team Assignment
77 ; DFN = pointer to patient
78 ; TMIEN = Ptr to Team Assignment File 404.42 for Team being discharged
79 ; SCAT = Discharge Date
80 ; SCDUZ = DUZ of user making reassignment
81 ; SD = text indicating "source" or "destination" team
82 N SC,SCTEC,DISDAT
83 ;
84 Q:TMIEN="" TMIEN ; Don't try to update this record if don't get IEN
85 S DISDAT=SCACT ; init discharge date
86 ; discharge for previous day if assignment date prior to today
87 I $P($G(^SCPT(404.42,TMIEN,0)),U,2)'>$$PREVDAY(SCACT) S DISDAT=$$PREVDAY(SCACT)
88 ; Discharge Position assignments first, to prevent posibility of orphan positions
89 D DISCHPOS(DFN,TMIEN,DISDAT,SCERR,.SCTEC) ; Discharge from any position Assignments on this team
90 I SCTEC S SCTEC=$$INPTTM^SCAPMC(DFN,TMIEN,DISDAT,SCERR) ; Discharge from team Assignments
91 I 'SCTEC D ERROR("Unable to discharge "_SD_" team",FASIEN,500) Q 0 ; BAIL OUT
92 Q SCTEC
93 ;
94DISCHPOS(DFN,TMASGN,SCAT,SCERR,SCTEC) ;Discharge positition assignments
95 ; DFN = ptr to patient
96 ; TMASGN = ptr to team assignment
97 ; SCAT = discharge date
98 N POSASGN,EM,GD,OK
99 S (EM,GD)=""
100 S OK=1
101 S SCTEC=1 ; initialize successfull pos discharge since may not be any pos to discharge
102 S POSASGN=0
103 F S POSASGN=$O(^SCPT(404.43,"B",TMASGN,POSASGN)) Q:POSASGN="" D
104 . S SCTEC=$$INPTTP^SCAPMC(DFN,POSASGN,SCAT,SCERR) ; discharge position
105 . I SCTEC S GD=GD_POSASGN_","
106 . I 'SCTEC D
107 .. S EM=EM_POSASGN_","
108 .. S OK=0
109 I 'OK D
110 . I GD'="" D ERROR("able to discharge these source positions: "_GD_" unable to discharge these: "_EM,POSASGN,300) Q
111 . D ERROR("unable to discharge any of the team positions: "_EM,POSASGN,400)
112 Q
113 ;
114PREVDAY(DAY) ; GET PREVIOUS DAY
115 ; DAY = DATE IN FILEMAN FORMAT
116 N X,X1,X2
117 S X1=DAY,X2=-1
118 D C^%DTC
119 Q X
120 ;
121GETTMPAR(DFN,SCTMTO,SCDT,SCERR,SCTMPAR,SCPTTM) ; RETURN team parameters
122 ; SCTMPAR is returned as:
123 ; Piece Description
124 ; 1 IEN of TEAM file entry
125 ; 2 Name of team
126 ; 3 IEN of file #404.42 (Pt Tm Assignment)
127 ; 4 current effective date
128 ; 5 current inactivate date (if any)
129 ; 6 pointer to 403.47 (purpose)
130 ; 7 Name of Purpose
131 ; 8 Is this the pt's PC Team?
132 ; 9 IEN of PC team assignment - added to record -PDR
133 N SCTMLST,SCPTTMDT,PCTM
134 S (SCPTTM,SCTMPAR,PCTM)="" ; initialize dest team IEN and dest team parameters
135 ; get a list of active or future active teams for this patient
136 S SCPTTMDT("BEGIN")=SCDT,SCPTTMDT("END")=3990101,SCPTTMDT("INCL")=0
137 I $$TMPT^SCAPMC3(DFN,"SCPTTMDT","","SCTMLST",.SCERR) D
138 . S PCTM=$$GETPCTM(.SCTMLST) ; get the PC team if any for this patient
139 . S:$D(SCTMLST("SCTM",SCTMTO)) SCPTTM=$O(SCTMLST("SCTM",SCTMTO,0))
140 . I SCPTTM D ; get the team parameters
141 .. S SCN=$O(SCTMLST("SCTM",SCTMTO,SCPTTM,"")) ; ordered list
142 .. S SCTMPAR=$G(SCTMLST(SCN)) ; basic team parameters
143 S $P(SCTMPAR,U,9)=+PCTM ; add ien of PC team as 9th piece
144 Q '$D(@SCERR)
145 ;
146GETPCTM(TMLIST) ; FIND THE PC TEAM FOR THIS PATIENT
147 N SN,PT
148 S (PT,SN)=0
149 F S SN=$O(TMLIST(SN)) Q:'SN D Q:PT
150 . I $P(TMLIST(SN),U,8) S PT=$P(TMLIST(SN),U,3)
151 Q PT
152 ;
153FUASSN(SCDTPAR,SCDT) ; is there a future assignment?
154 Q $P(SCTMPAR,U,4)>SCDT
155 ;
156FUDISCHG(SCTMPAR,SCDT) ;IS THERE A FUTURE DISCHARGE?
157 Q $P(SCTMPAR,U,5)>SCDT
158 ;
159MOVPATOK(DFN,SCACT,SCTMTO,SCFIELDA,SCTMPAR,SCPTTM,SCDUZ) ; DID MOVE GO OK?
160 N SCFLD,SCED
161 S SCED=0
162 I SCPTTM D ; setup for edit of existing dest assignment record
163 . S SCPTTM=SCPTTM_"," ; IENS format
164 . I $$FUASSN(SCTMPAR,SCACT) S SCED=1 ; the new assign date wil be entered below
165 . I $$FUDISCHG(SCTMPAR,SCACT) D ; is there a future discharge for the dest team?
166 .. S SCED=1
167 .. S SC($J,404.42,SCPTTM,.09)="" ; remove discharge date
168 . I SCED D ; editing the existing assignment - setup edit documentation fields
169 .. S SC($J,404.42,SCPTTM,.13)=@SCFIELDA@(.11) ; last edited by set to entered by
170 .. S SC($J,404.42,SCPTTM,.14)=@SCFIELDA@(.12) ; last edit time set to enter date/time
171 .. K @SCFIELDA@(.11) ; dispose of entered by (SCFIELDA array is set in SCMRBK)
172 .. K @SCFIELDA@(.12) ; dispose of entry date/time
173 ;
174 I '(+SCPTTM) S SCPTTM="+1," ; setup for new team
175 ;
176 S SCFLD=0 ; add additional fields from workstation if any
177 F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
178 . S SC($J,404.42,SCPTTM,SCFLD)=@SCFIELDA@(SCFLD)
179 ; core fields for new team assignment
180 S SC($J,404.42,SCPTTM,.01)=DFN
181 S SC($J,404.42,SCPTTM,.02)=SCACT
182 S SC($J,404.42,SCPTTM,.03)=SCTMTO
183 ;
184 I 'SCED D UPDATE^DIE("","SC($J)","SCIEN","SCERR") ; new entry
185 I SCED D FILE^DIE("","SC($J)","SCERR") ; edit existing entry
186 ;
187 IF $D(@SCERR) D
188 . K SCIEN
189 . S SCPTTM=""
190 ELSE D
191 . I SCPTTM'="+1," Q ; BAIL OUT - was edit to existing assignement record
192 . S SCPTTM=$G(SCIEN(1)) ; new assignment record set up
193 . S SCNEWTM=1
194 . D AFTERTM^SCMCDD1(SCPTTM)
195 Q '$D(@SCERR)
196 ;
197INVALMOV(DTMIEN,STMIEN,TMPAR) ; IS THIS A VALID REASSIGNMENT?
198 ; can't have a pc team reassignment if patient has an existing PC team assignment
199 ; and it is not
200 ; 1: the src team (move from src to dest discharges src, result only 1 pc team) OR
201 ; 2: the destination team (already existing assignment)
202 I $$PCASSGN,$$OTHPCTM(DTMIEN,STMIEN,TMPAR) Q 1
203 Q 0
204 ;
205PCASSGN() ; IS THE REASSIGNMENT DESTINATION TO BE PC?
206 Q @SCFIELDA@(.08)=1
207 ;
208OTHPCTM(DTMIEN,STMIEN,TMPAR) ; IS THERE ALREADY PC TEAM ASSIGNMENT?
209 I $P(TMPAR,U,9)=0 Q 0 ; no other primary care assignments
210 I 'DTMIEN Q $P(TMPAR,U,9)'=STMIEN ; true if PC team is not source team
211 Q $P(TMPAR,U,9)'=DTMIEN ; true if existing dest team assign is not pc team
212 ;
213ACTIVDES(SCDTPAR,SCACT) ; IS THE DESTINATION ASSIGNMENT ACTIVE?
214 ; SCDTPAR = Destination Team assignment parameter string
215 N DISDT,ASNDT
216 S DISDT=$P(SCDTPAR,U,5)
217 I DISDT="" S DISDT=9999999
218 S ASNDT=$P(SCDTPAR,U,4)
219 ; ACTIVE if assign date is not in future and
220 ; there is no discharge date, or the discharge date is in the future
221 I (ASNDT'>SCACT)&(DISDT>SCACT) Q 1
222 Q 0
223 ;
224ERROR(TXT,ID,ERN) ; ERROR PROCESSOR
225 S SCMESS=TXT_" IEN="_ID_" (ER#="_ERN_")"
226 S SCPTTM=0 ; return no assignment ien
227 ;S ^TMP("PDR",$J,$H,DFN)=SCMESS
228 Q
Note: See TracBrowser for help on using the repository browser.