| 1 | SCRPMTA ;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
|
|---|
| 7 | ACPTTM(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 | ;
|
|---|
| 52 | APTTMQ ;
|
|---|
| 53 | ;B
|
|---|
| 54 | Q +$G(SCPTTM)_U_+$G(SCNEWTM)_U_$G(SCMESS)
|
|---|
| 55 | ;
|
|---|
| 56 | ;-------------------- SUBS -------------------------------
|
|---|
| 57 | ;
|
|---|
| 58 | PTTMACT(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 | ;
|
|---|
| 65 | OKDATA() ;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 | ;
|
|---|
| 76 | DISTMOK(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 | ;
|
|---|
| 94 | DISCHPOS(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 | ;
|
|---|
| 114 | PREVDAY(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 | ;
|
|---|
| 121 | GETTMPAR(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 | ;
|
|---|
| 146 | GETPCTM(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 | ;
|
|---|
| 153 | FUASSN(SCDTPAR,SCDT) ; is there a future assignment?
|
|---|
| 154 | Q $P(SCTMPAR,U,4)>SCDT
|
|---|
| 155 | ;
|
|---|
| 156 | FUDISCHG(SCTMPAR,SCDT) ;IS THERE A FUTURE DISCHARGE?
|
|---|
| 157 | Q $P(SCTMPAR,U,5)>SCDT
|
|---|
| 158 | ;
|
|---|
| 159 | MOVPATOK(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 | ;
|
|---|
| 197 | INVALMOV(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 | ;
|
|---|
| 205 | PCASSGN() ; IS THE REASSIGNMENT DESTINATION TO BE PC?
|
|---|
| 206 | Q @SCFIELDA@(.08)=1
|
|---|
| 207 | ;
|
|---|
| 208 | OTHPCTM(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 | ;
|
|---|
| 213 | ACTIVDES(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 | ;
|
|---|
| 224 | ERROR(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
|
|---|
