SCRPMTA ;ALB/REW/PDR - Team Reassignment APIs:APPTTM ; AUG 1998
;;5.3;scheduling;**148,157**;aug 13, 1993
; Reassign patient Team, called from RPC ='SC FILE PAT TM REASGN' (PTFILE^SCMRBK - PTFILE^SCMRBK)
;
;;1.0
; MAKE A SINGLE PATIENT TEAM REASSIGNMENT
ACPTTM(DFN,SCTMTO,SCFIELDA,SCACT,FASIEN,SCERR) ;add a patient to a team (pt tmassgn - #404.42)
; input:
; DFN = pointer to PATIENT file (#2)
; SCTMTO = pointer to TEAM file (#404.51) "TO" Team
; SCFIELDA= array of additional fields to be added for 404.42
; SCACT = date to activate [default=DT]
; FASIEN = IEN of source team assignment
; SCERR = array NAME to store error messages.
; [ex. ^TMP("ORXX",$J)]
;
; Output:
; Returned = ien of 404.42 - 0 if none after^new?^Message
; SCERR() = Array of DIALOG file messages(errors) .
; Foramt:
; Subscript: Sequential # from 1 to n
; Piece Description
; 1 IEN of DIALOG file
N SCPTTM,SCESEQ,SCPARM,SCIEN,SC,SCFLD,SCNEWTM,SCDTPAR,SCMESS
;
;
I '$$OKDATA D G APTTMQ ;check/setup variables
. D ERROR("Failed initial data check","",10)
;
; PROCESS REASSIGNMENT
; get destination team assignment parameters if already existing assignment
I '$$GETTMPAR(DFN,SCTMTO,SCACT,.SCERR,.SCDTPAR,.SCPTTM) D G APTTMQ ; BAIL if error
. D ERROR("Unable to get list of team assignments for patient",FASIEN,20)
; Make sure this reassignment doesn't set up more than 1 primary care team for PT
I $$INVALMOV(SCPTTM,FASIEN,SCDTPAR) D G APTTMQ ; BAIL if error
. D ERROR("Patient already has a primary care assignment",FASIEN,30)
;
; check for currently active destination assignment and discharge if so
I $$ACTIVDES(SCDTPAR,SCACT) D G:SCPTTM APTTMQ ; BAIL OUT if discharge unsuccessfull
. I $$DISTMOK(DFN,SCPTTM,SCACT,DUZ,"Destination") S SCPTTM="" Q ; going to create a new team
. D ERROR("Unable to discharge current destination assignment",SCPTTM,40)
;
; discharge source team
I '$$DISTMOK(DFN,FASIEN,SCACT,DUZ,"Source") D G APTTMQ
. ; error messages setup within call to DISTMOK
. S SCPTTM=""
;
; Move the patient to destination team and create destination team if necessary
I '$$MOVPATOK(DFN,SCACT,SCTMTO,SCFIELDA,SCDTPAR,.SCPTTM,DUZ) D G APTTMQ
. D ERROR("Unable to move patient to destination team",FASIEN,50)
;
APTTMQ ;
;B
Q +$G(SCPTTM)_U_+$G(SCNEWTM)_U_$G(SCMESS)
;
;-------------------- SUBS -------------------------------
;
PTTMACT(DFN,SCTMTO,SCDT,SCERR) ;what is patient/team assignment on a given date-time into the future? Return 404.42 ien or 0
N SCTMLST,SCOK,SCPTTMDT
S SCOK=0
S SCPTTMDT("BEGIN")=SCDT,SCPTTMDT("END")=3990101,SCPTTMDT("INCL")=0
IF $$TMPT^SCAPMC3(DFN,"SCPTTMDT","","SCTMLST",.SCERR) S:$D(SCTMLST("SCTM",SCTMTO)) SCOK=$O(SCTMLST("SCTM",SCTMTO,0))
Q SCOK
;
OKDATA() ;setup/check variables
N SCOK
S SCOK=1
D INIT^SCAPMCU1(.SCOK)
IF '$D(^DPT(DFN,0))!('$D(^SCTM(404.51,SCTMTO,0))) D S SCOK=0
. S SCPARM("PATIENT")=DFN
. S SCPARM("TEAM")=SCTMTO
. D ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
S:'$G(SCACT) SCACT=DT
Q SCOK
;
DISTMOK(DFN,TMIEN,SCACT,SCDUZ,SD) ; Discharge patient from Team Assignment
; DFN = pointer to patient
; TMIEN = Ptr to Team Assignment File 404.42 for Team being discharged
; SCAT = Discharge Date
; SCDUZ = DUZ of user making reassignment
; SD = text indicating "source" or "destination" team
N SC,SCTEC,DISDAT
;
Q:TMIEN="" TMIEN ; Don't try to update this record if don't get IEN
S DISDAT=SCACT ; init discharge date
; discharge for previous day if assignment date prior to today
I $P($G(^SCPT(404.42,TMIEN,0)),U,2)'>$$PREVDAY(SCACT) S DISDAT=$$PREVDAY(SCACT)
; Discharge Position assignments first, to prevent posibility of orphan positions
D DISCHPOS(DFN,TMIEN,DISDAT,SCERR,.SCTEC) ; Discharge from any position Assignments on this team
I SCTEC S SCTEC=$$INPTTM^SCAPMC(DFN,TMIEN,DISDAT,SCERR) ; Discharge from team Assignments
I 'SCTEC D ERROR("Unable to discharge "_SD_" team",FASIEN,500) Q 0 ; BAIL OUT
Q SCTEC
;
DISCHPOS(DFN,TMASGN,SCAT,SCERR,SCTEC) ;Discharge positition assignments
; DFN = ptr to patient
; TMASGN = ptr to team assignment
; SCAT = discharge date
N POSASGN,EM,GD,OK
S (EM,GD)=""
S OK=1
S SCTEC=1 ; initialize successfull pos discharge since may not be any pos to discharge
S POSASGN=0
F S POSASGN=$O(^SCPT(404.43,"B",TMASGN,POSASGN)) Q:POSASGN="" D
. S SCTEC=$$INPTTP^SCAPMC(DFN,POSASGN,SCAT,SCERR) ; discharge position
. I SCTEC S GD=GD_POSASGN_","
. I 'SCTEC D
.. S EM=EM_POSASGN_","
.. S OK=0
I 'OK D
. I GD'="" D ERROR("able to discharge these source positions: "_GD_" unable to discharge these: "_EM,POSASGN,300) Q
. D ERROR("unable to discharge any of the team positions: "_EM,POSASGN,400)
Q
;
PREVDAY(DAY) ; GET PREVIOUS DAY
; DAY = DATE IN FILEMAN FORMAT
N X,X1,X2
S X1=DAY,X2=-1
D C^%DTC
Q X
;
GETTMPAR(DFN,SCTMTO,SCDT,SCERR,SCTMPAR,SCPTTM) ; RETURN team parameters
; SCTMPAR is returned as:
; Piece Description
; 1 IEN of TEAM file entry
; 2 Name of team
; 3 IEN of file #404.42 (Pt Tm Assignment)
; 4 current effective date
; 5 current inactivate date (if any)
; 6 pointer to 403.47 (purpose)
; 7 Name of Purpose
; 8 Is this the pt's PC Team?
; 9 IEN of PC team assignment - added to record -PDR
N SCTMLST,SCPTTMDT,PCTM
S (SCPTTM,SCTMPAR,PCTM)="" ; initialize dest team IEN and dest team parameters
; get a list of active or future active teams for this patient
S SCPTTMDT("BEGIN")=SCDT,SCPTTMDT("END")=3990101,SCPTTMDT("INCL")=0
I $$TMPT^SCAPMC3(DFN,"SCPTTMDT","","SCTMLST",.SCERR) D
. S PCTM=$$GETPCTM(.SCTMLST) ; get the PC team if any for this patient
. S:$D(SCTMLST("SCTM",SCTMTO)) SCPTTM=$O(SCTMLST("SCTM",SCTMTO,0))
. I SCPTTM D ; get the team parameters
.. S SCN=$O(SCTMLST("SCTM",SCTMTO,SCPTTM,"")) ; ordered list
.. S SCTMPAR=$G(SCTMLST(SCN)) ; basic team parameters
S $P(SCTMPAR,U,9)=+PCTM ; add ien of PC team as 9th piece
Q '$D(@SCERR)
;
GETPCTM(TMLIST) ; FIND THE PC TEAM FOR THIS PATIENT
N SN,PT
S (PT,SN)=0
F S SN=$O(TMLIST(SN)) Q:'SN D Q:PT
. I $P(TMLIST(SN),U,8) S PT=$P(TMLIST(SN),U,3)
Q PT
;
FUASSN(SCDTPAR,SCDT) ; is there a future assignment?
Q $P(SCTMPAR,U,4)>SCDT
;
FUDISCHG(SCTMPAR,SCDT) ;IS THERE A FUTURE DISCHARGE?
Q $P(SCTMPAR,U,5)>SCDT
;
MOVPATOK(DFN,SCACT,SCTMTO,SCFIELDA,SCTMPAR,SCPTTM,SCDUZ) ; DID MOVE GO OK?
N SCFLD,SCED
S SCED=0
I SCPTTM D ; setup for edit of existing dest assignment record
. S SCPTTM=SCPTTM_"," ; IENS format
. I $$FUASSN(SCTMPAR,SCACT) S SCED=1 ; the new assign date wil be entered below
. I $$FUDISCHG(SCTMPAR,SCACT) D ; is there a future discharge for the dest team?
.. S SCED=1
.. S SC($J,404.42,SCPTTM,.09)="" ; remove discharge date
. I SCED D ; editing the existing assignment - setup edit documentation fields
.. S SC($J,404.42,SCPTTM,.13)=@SCFIELDA@(.11) ; last edited by set to entered by
.. S SC($J,404.42,SCPTTM,.14)=@SCFIELDA@(.12) ; last edit time set to enter date/time
.. K @SCFIELDA@(.11) ; dispose of entered by (SCFIELDA array is set in SCMRBK)
.. K @SCFIELDA@(.12) ; dispose of entry date/time
;
I '(+SCPTTM) S SCPTTM="+1," ; setup for new team
;
S SCFLD=0 ; add additional fields from workstation if any
F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
. S SC($J,404.42,SCPTTM,SCFLD)=@SCFIELDA@(SCFLD)
; core fields for new team assignment
S SC($J,404.42,SCPTTM,.01)=DFN
S SC($J,404.42,SCPTTM,.02)=SCACT
S SC($J,404.42,SCPTTM,.03)=SCTMTO
;
I 'SCED D UPDATE^DIE("","SC($J)","SCIEN","SCERR") ; new entry
I SCED D FILE^DIE("","SC($J)","SCERR") ; edit existing entry
;
IF $D(@SCERR) D
. K SCIEN
. S SCPTTM=""
ELSE D
. I SCPTTM'="+1," Q ; BAIL OUT - was edit to existing assignement record
. S SCPTTM=$G(SCIEN(1)) ; new assignment record set up
. S SCNEWTM=1
. D AFTERTM^SCMCDD1(SCPTTM)
Q '$D(@SCERR)
;
INVALMOV(DTMIEN,STMIEN,TMPAR) ; IS THIS A VALID REASSIGNMENT?
; can't have a pc team reassignment if patient has an existing PC team assignment
; and it is not
; 1: the src team (move from src to dest discharges src, result only 1 pc team) OR
; 2: the destination team (already existing assignment)
I $$PCASSGN,$$OTHPCTM(DTMIEN,STMIEN,TMPAR) Q 1
Q 0
;
PCASSGN() ; IS THE REASSIGNMENT DESTINATION TO BE PC?
Q @SCFIELDA@(.08)=1
;
OTHPCTM(DTMIEN,STMIEN,TMPAR) ; IS THERE ALREADY PC TEAM ASSIGNMENT?
I $P(TMPAR,U,9)=0 Q 0 ; no other primary care assignments
I 'DTMIEN Q $P(TMPAR,U,9)'=STMIEN ; true if PC team is not source team
Q $P(TMPAR,U,9)'=DTMIEN ; true if existing dest team assign is not pc team
;
ACTIVDES(SCDTPAR,SCACT) ; IS THE DESTINATION ASSIGNMENT ACTIVE?
; SCDTPAR = Destination Team assignment parameter string
N DISDT,ASNDT
S DISDT=$P(SCDTPAR,U,5)
I DISDT="" S DISDT=9999999
S ASNDT=$P(SCDTPAR,U,4)
; ACTIVE if assign date is not in future and
; there is no discharge date, or the discharge date is in the future
I (ASNDT'>SCACT)&(DISDT>SCACT) Q 1
Q 0
;
ERROR(TXT,ID,ERN) ; ERROR PROCESSOR
S SCMESS=TXT_" IEN="_ID_" (ER#="_ERN_")"
S SCPTTM=0 ; return no assignment ien
;S ^TMP("PDR",$J,$H,DFN)=SCMESS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPMTA 9534 printed Sep 23, 2025@20:18:59 Page 2
SCRPMTA ;ALB/REW/PDR - Team Reassignment APIs:APPTTM ; AUG 1998
+1 ;;5.3;scheduling;**148,157**;aug 13, 1993
+2 ; Reassign patient Team, called from RPC ='SC FILE PAT TM REASGN' (PTFILE^SCMRBK - PTFILE^SCMRBK)
+3 ;
+4 ;;1.0
+5 ; MAKE A SINGLE PATIENT TEAM REASSIGNMENT
ACPTTM(DFN,SCTMTO,SCFIELDA,SCACT,FASIEN,SCERR) ;add a patient to a team (pt tmassgn - #404.42)
+1 ; input:
+2 ; DFN = pointer to PATIENT file (#2)
+3 ; SCTMTO = pointer to TEAM file (#404.51) "TO" Team
+4 ; SCFIELDA= array of additional fields to be added for 404.42
+5 ; SCACT = date to activate [default=DT]
+6 ; FASIEN = IEN of source team assignment
+7 ; SCERR = array NAME to store error messages.
+8 ; [ex. ^TMP("ORXX",$J)]
+9 ;
+10 ; Output:
+11 ; Returned = ien of 404.42 - 0 if none after^new?^Message
+12 ; SCERR() = Array of DIALOG file messages(errors) .
+13 ; Foramt:
+14 ; Subscript: Sequential # from 1 to n
+15 ; Piece Description
+16 ; 1 IEN of DIALOG file
+17 NEW SCPTTM,SCESEQ,SCPARM,SCIEN,SC,SCFLD,SCNEWTM,SCDTPAR,SCMESS
+18 ;
+19 ;
+20 ;check/setup variables
IF '$$OKDATA
Begin DoDot:1
+21 DO ERROR("Failed initial data check","",10)
End DoDot:1
GOTO APTTMQ
+22 ;
+23 ; PROCESS REASSIGNMENT
+24 ; get destination team assignment parameters if already existing assignment
+25 ; BAIL if error
IF '$$GETTMPAR(DFN,SCTMTO,SCACT,.SCERR,.SCDTPAR,.SCPTTM)
Begin DoDot:1
+26 DO ERROR("Unable to get list of team assignments for patient",FASIEN,20)
End DoDot:1
GOTO APTTMQ
+27 ; Make sure this reassignment doesn't set up more than 1 primary care team for PT
+28 ; BAIL if error
IF $$INVALMOV(SCPTTM,FASIEN,SCDTPAR)
Begin DoDot:1
+29 DO ERROR("Patient already has a primary care assignment",FASIEN,30)
End DoDot:1
GOTO APTTMQ
+30 ;
+31 ; check for currently active destination assignment and discharge if so
+32 ; BAIL OUT if discharge unsuccessfull
IF $$ACTIVDES(SCDTPAR,SCACT)
Begin DoDot:1
+33 ; going to create a new team
IF $$DISTMOK(DFN,SCPTTM,SCACT,DUZ,"Destination")
SET SCPTTM=""
QUIT
+34 DO ERROR("Unable to discharge current destination assignment",SCPTTM,40)
End DoDot:1
if SCPTTM
GOTO APTTMQ
+35 ;
+36 ; discharge source team
+37 IF '$$DISTMOK(DFN,FASIEN,SCACT,DUZ,"Source")
Begin DoDot:1
+38 ; error messages setup within call to DISTMOK
+39 SET SCPTTM=""
End DoDot:1
GOTO APTTMQ
+40 ;
+41 ; Move the patient to destination team and create destination team if necessary
+42 IF '$$MOVPATOK(DFN,SCACT,SCTMTO,SCFIELDA,SCDTPAR,.SCPTTM,DUZ)
Begin DoDot:1
+43 DO ERROR("Unable to move patient to destination team",FASIEN,50)
End DoDot:1
GOTO APTTMQ
+44 ;
APTTMQ ;
+1 ;B
+2 QUIT +$GET(SCPTTM)_U_+$GET(SCNEWTM)_U_$GET(SCMESS)
+3 ;
+4 ;-------------------- SUBS -------------------------------
+5 ;
PTTMACT(DFN,SCTMTO,SCDT,SCERR) ;what is patient/team assignment on a given date-time into the future? Return 404.42 ien or 0
+1 NEW SCTMLST,SCOK,SCPTTMDT
+2 SET SCOK=0
+3 SET SCPTTMDT("BEGIN")=SCDT
SET SCPTTMDT("END")=3990101
SET SCPTTMDT("INCL")=0
+4 IF $$TMPT^SCAPMC3(DFN,"SCPTTMDT","","SCTMLST",.SCERR)
if $DATA(SCTMLST("SCTM",SCTMTO))
SET SCOK=$ORDER(SCTMLST("SCTM",SCTMTO,0))
+5 QUIT SCOK
+6 ;
OKDATA() ;setup/check variables
+1 NEW SCOK
+2 SET SCOK=1
+3 DO INIT^SCAPMCU1(.SCOK)
+4 IF '$DATA(^DPT(DFN,0))!('$DATA(^SCTM(404.51,SCTMTO,0)))
Begin DoDot:1
+5 SET SCPARM("PATIENT")=DFN
+6 SET SCPARM("TEAM")=SCTMTO
+7 DO ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
SET SCOK=0
+8 if '$GET(SCACT)
SET SCACT=DT
+9 QUIT SCOK
+10 ;
DISTMOK(DFN,TMIEN,SCACT,SCDUZ,SD) ; Discharge patient from Team Assignment
+1 ; DFN = pointer to patient
+2 ; TMIEN = Ptr to Team Assignment File 404.42 for Team being discharged
+3 ; SCAT = Discharge Date
+4 ; SCDUZ = DUZ of user making reassignment
+5 ; SD = text indicating "source" or "destination" team
+6 NEW SC,SCTEC,DISDAT
+7 ;
+8 ; Don't try to update this record if don't get IEN
if TMIEN=""
QUIT TMIEN
+9 ; init discharge date
SET DISDAT=SCACT
+10 ; discharge for previous day if assignment date prior to today
+11 IF $PIECE($GET(^SCPT(404.42,TMIEN,0)),U,2)'>$$PREVDAY(SCACT)
SET DISDAT=$$PREVDAY(SCACT)
+12 ; Discharge Position assignments first, to prevent posibility of orphan positions
+13 ; Discharge from any position Assignments on this team
DO DISCHPOS(DFN,TMIEN,DISDAT,SCERR,.SCTEC)
+14 ; Discharge from team Assignments
IF SCTEC
SET SCTEC=$$INPTTM^SCAPMC(DFN,TMIEN,DISDAT,SCERR)
+15 ; BAIL OUT
IF 'SCTEC
DO ERROR("Unable to discharge "_SD_" team",FASIEN,500)
QUIT 0
+16 QUIT SCTEC
+17 ;
DISCHPOS(DFN,TMASGN,SCAT,SCERR,SCTEC) ;Discharge positition assignments
+1 ; DFN = ptr to patient
+2 ; TMASGN = ptr to team assignment
+3 ; SCAT = discharge date
+4 NEW POSASGN,EM,GD,OK
+5 SET (EM,GD)=""
+6 SET OK=1
+7 ; initialize successfull pos discharge since may not be any pos to discharge
SET SCTEC=1
+8 SET POSASGN=0
+9 FOR
SET POSASGN=$ORDER(^SCPT(404.43,"B",TMASGN,POSASGN))
if POSASGN=""
QUIT
Begin DoDot:1
+10 ; discharge position
SET SCTEC=$$INPTTP^SCAPMC(DFN,POSASGN,SCAT,SCERR)
+11 IF SCTEC
SET GD=GD_POSASGN_","
+12 IF 'SCTEC
Begin DoDot:2
+13 SET EM=EM_POSASGN_","
+14 SET OK=0
End DoDot:2
End DoDot:1
+15 IF 'OK
Begin DoDot:1
+16 IF GD'=""
DO ERROR("able to discharge these source positions: "_GD_" unable to discharge these: "_EM,POSASGN,300)
QUIT
+17 DO ERROR("unable to discharge any of the team positions: "_EM,POSASGN,400)
End DoDot:1
+18 QUIT
+19 ;
PREVDAY(DAY) ; GET PREVIOUS DAY
+1 ; DAY = DATE IN FILEMAN FORMAT
+2 NEW X,X1,X2
+3 SET X1=DAY
SET X2=-1
+4 DO C^%DTC
+5 QUIT X
+6 ;
GETTMPAR(DFN,SCTMTO,SCDT,SCERR,SCTMPAR,SCPTTM) ; RETURN team parameters
+1 ; SCTMPAR is returned as:
+2 ; Piece Description
+3 ; 1 IEN of TEAM file entry
+4 ; 2 Name of team
+5 ; 3 IEN of file #404.42 (Pt Tm Assignment)
+6 ; 4 current effective date
+7 ; 5 current inactivate date (if any)
+8 ; 6 pointer to 403.47 (purpose)
+9 ; 7 Name of Purpose
+10 ; 8 Is this the pt's PC Team?
+11 ; 9 IEN of PC team assignment - added to record -PDR
+12 NEW SCTMLST,SCPTTMDT,PCTM
+13 ; initialize dest team IEN and dest team parameters
SET (SCPTTM,SCTMPAR,PCTM)=""
+14 ; get a list of active or future active teams for this patient
+15 SET SCPTTMDT("BEGIN")=SCDT
SET SCPTTMDT("END")=3990101
SET SCPTTMDT("INCL")=0
+16 IF $$TMPT^SCAPMC3(DFN,"SCPTTMDT","","SCTMLST",.SCERR)
Begin DoDot:1
+17 ; get the PC team if any for this patient
SET PCTM=$$GETPCTM(.SCTMLST)
+18 if $DATA(SCTMLST("SCTM",SCTMTO))
SET SCPTTM=$ORDER(SCTMLST("SCTM",SCTMTO,0))
+19 ; get the team parameters
IF SCPTTM
Begin DoDot:2
+20 ; ordered list
SET SCN=$ORDER(SCTMLST("SCTM",SCTMTO,SCPTTM,""))
+21 ; basic team parameters
SET SCTMPAR=$GET(SCTMLST(SCN))
End DoDot:2
End DoDot:1
+22 ; add ien of PC team as 9th piece
SET $PIECE(SCTMPAR,U,9)=+PCTM
+23 QUIT '$DATA(@SCERR)
+24 ;
GETPCTM(TMLIST) ; FIND THE PC TEAM FOR THIS PATIENT
+1 NEW SN,PT
+2 SET (PT,SN)=0
+3 FOR
SET SN=$ORDER(TMLIST(SN))
if 'SN
QUIT
Begin DoDot:1
+4 IF $PIECE(TMLIST(SN),U,8)
SET PT=$PIECE(TMLIST(SN),U,3)
End DoDot:1
if PT
QUIT
+5 QUIT PT
+6 ;
FUASSN(SCDTPAR,SCDT) ; is there a future assignment?
+1 QUIT $PIECE(SCTMPAR,U,4)>SCDT
+2 ;
FUDISCHG(SCTMPAR,SCDT) ;IS THERE A FUTURE DISCHARGE?
+1 QUIT $PIECE(SCTMPAR,U,5)>SCDT
+2 ;
MOVPATOK(DFN,SCACT,SCTMTO,SCFIELDA,SCTMPAR,SCPTTM,SCDUZ) ; DID MOVE GO OK?
+1 NEW SCFLD,SCED
+2 SET SCED=0
+3 ; setup for edit of existing dest assignment record
IF SCPTTM
Begin DoDot:1
+4 ; IENS format
SET SCPTTM=SCPTTM_","
+5 ; the new assign date wil be entered below
IF $$FUASSN(SCTMPAR,SCACT)
SET SCED=1
+6 ; is there a future discharge for the dest team?
IF $$FUDISCHG(SCTMPAR,SCACT)
Begin DoDot:2
+7 SET SCED=1
+8 ; remove discharge date
SET SC($JOB,404.42,SCPTTM,.09)=""
End DoDot:2
+9 ; editing the existing assignment - setup edit documentation fields
IF SCED
Begin DoDot:2
+10 ; last edited by set to entered by
SET SC($JOB,404.42,SCPTTM,.13)=@SCFIELDA@(.11)
+11 ; last edit time set to enter date/time
SET SC($JOB,404.42,SCPTTM,.14)=@SCFIELDA@(.12)
+12 ; dispose of entered by (SCFIELDA array is set in SCMRBK)
KILL @SCFIELDA@(.11)
+13 ; dispose of entry date/time
KILL @SCFIELDA@(.12)
End DoDot:2
End DoDot:1
+14 ;
+15 ; setup for new team
IF '(+SCPTTM)
SET SCPTTM="+1,"
+16 ;
+17 ; add additional fields from workstation if any
SET SCFLD=0
+18 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:1
+19 SET SC($JOB,404.42,SCPTTM,SCFLD)=@SCFIELDA@(SCFLD)
End DoDot:1
+20 ; core fields for new team assignment
+21 SET SC($JOB,404.42,SCPTTM,.01)=DFN
+22 SET SC($JOB,404.42,SCPTTM,.02)=SCACT
+23 SET SC($JOB,404.42,SCPTTM,.03)=SCTMTO
+24 ;
+25 ; new entry
IF 'SCED
DO UPDATE^DIE("","SC($J)","SCIEN","SCERR")
+26 ; edit existing entry
IF SCED
DO FILE^DIE("","SC($J)","SCERR")
+27 ;
+28 IF $DATA(@SCERR)
Begin DoDot:1
+29 KILL SCIEN
+30 SET SCPTTM=""
End DoDot:1
+31 IF '$TEST
Begin DoDot:1
+32 ; BAIL OUT - was edit to existing assignement record
IF SCPTTM'="+1,"
QUIT
+33 ; new assignment record set up
SET SCPTTM=$GET(SCIEN(1))
+34 SET SCNEWTM=1
+35 DO AFTERTM^SCMCDD1(SCPTTM)
End DoDot:1
+36 QUIT '$DATA(@SCERR)
+37 ;
INVALMOV(DTMIEN,STMIEN,TMPAR) ; IS THIS A VALID REASSIGNMENT?
+1 ; can't have a pc team reassignment if patient has an existing PC team assignment
+2 ; and it is not
+3 ; 1: the src team (move from src to dest discharges src, result only 1 pc team) OR
+4 ; 2: the destination team (already existing assignment)
+5 IF $$PCASSGN
IF $$OTHPCTM(DTMIEN,STMIEN,TMPAR)
QUIT 1
+6 QUIT 0
+7 ;
PCASSGN() ; IS THE REASSIGNMENT DESTINATION TO BE PC?
+1 QUIT @SCFIELDA@(.08)=1
+2 ;
OTHPCTM(DTMIEN,STMIEN,TMPAR) ; IS THERE ALREADY PC TEAM ASSIGNMENT?
+1 ; no other primary care assignments
IF $PIECE(TMPAR,U,9)=0
QUIT 0
+2 ; true if PC team is not source team
IF 'DTMIEN
QUIT $PIECE(TMPAR,U,9)'=STMIEN
+3 ; true if existing dest team assign is not pc team
QUIT $PIECE(TMPAR,U,9)'=DTMIEN
+4 ;
ACTIVDES(SCDTPAR,SCACT) ; IS THE DESTINATION ASSIGNMENT ACTIVE?
+1 ; SCDTPAR = Destination Team assignment parameter string
+2 NEW DISDT,ASNDT
+3 SET DISDT=$PIECE(SCDTPAR,U,5)
+4 IF DISDT=""
SET DISDT=9999999
+5 SET ASNDT=$PIECE(SCDTPAR,U,4)
+6 ; ACTIVE if assign date is not in future and
+7 ; there is no discharge date, or the discharge date is in the future
+8 IF (ASNDT'>SCACT)&(DISDT>SCACT)
QUIT 1
+9 QUIT 0
+10 ;
ERROR(TXT,ID,ERN) ; ERROR PROCESSOR
+1 SET SCMESS=TXT_" IEN="_ID_" (ER#="_ERN_")"
+2 ; return no assignment ien
SET SCPTTM=0
+3 ;S ^TMP("PDR",$J,$H,DFN)=SCMESS
+4 QUIT
