SCRPM21U ;ALB/PDR - POSITION REASSIGNMENT UTILITIES ; AUG 1998
;;5.3;Scheduling;**148,157**;Aug 13, 1993
;
PREVDAY(DAY) ; GET PREVIOUS DAY
N X,X1,X2
S X1=DAY,X2=-1
D C^%DTC
Q X
;
PCPCASN(FASIEN,SCTP) ; IS THIS A PRIMARY CARE to PRIMARY CARE ASSIGNMENT?
; FASIEN = Pointer to source Position assignment SCPT(404.43)
; SCTP = Destination position pointer to Position DEF file SCTM(404.57)
N SPPC,DPPC,STPC,SCST
; Exclude the case where source = destination team
;
S SCST=$P($G(^SCPT(404.43,FASIEN,0)),U,2) ; pointer to position DEF file
S SCST=$P($G(^SCTM(404.57,SCST,0)),U,2) ; pointer to team DEF file
I SCST="" Q 0 ; this is really an error condition
I SCST=$P($G(^SCTM(404.57,SCTP,0)),U,2) Q 0 ; source and dest teams are the same
;
; Both source and destination positions are (or will be) primary care.
;
; test source position is a pc position, and the new position is too
S SPPC=$P($G(^SCPT(404.43,FASIEN,0)),U,5)>0 ; source position is primary care
S DPPC=@SCFIELDA@(.05)>0 ; destination position is primary care
S STPC=$$GETPOSTM(FASIEN)
S STPC=$P($G(^SCPT(404.42,STPC,0)),U,8)=1 ; source team is primary care
; if source pos and dest pos are PC OR source team and dest pos are PC then is a pc to pc assignment
Q (SPPC&DPPC)!(STPC&DPPC)
;
UPDATPOS(POSAIEN,SCERR) ; UPDATE EXISTING POSITION ASSIGNMENT PARAMETERS, AND ENSURE NO FUTURE DISCHARGE
N SC,SCFLD,ENTFLD
S ENTFLD=",.06,.07,"
S SC($J,404.43,(+POSAIEN)_",",.08)=DUZ ; last edited by
S SC($J,404.43,(+POSAIEN)_",",.09)=SCNOW ; last edit date/time
S SC($J,404.43,(+POSAIEN)_",",.03)=SCACT ; set new activity date for existing position assgn
S SC($J,404.43,(+POSAIEN)_",",.04)="" ; ensure no future discharge
IF $D(SCFIELDA) D
. S SCFLD=0
. F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
.. Q:ENTFLD[","_SCFLD_"," ; don't want ENTRY user and ENTRY date time for edit
.. S SC($J,404.43,(+POSAIEN)_",",SCFLD)=@SCFIELDA@(SCFLD)
D FILE^DIE("","SC($J)",SCERR) ; update position assignment paramaeters
I $D(@SCERR) S POSAIEN=0_U_POSAIEN
Q
;
TMEXIST(DFN,SCTM,SCSD,TMAIEN) ;
; returns 1 if current/future assignment exists else 0
; conserves IEN of the des tm asgn if it exists
N SCRESULT,SCSDT,SCX,SCTMLIST,SCTMERR
S (SCRESULT,TMAIEN)=0
;
;;set date variables for $$tmpt
S SCSDT("BEGIN")=$G(SCSD,DT)
S SCSDT("END")=$$FMADD^XLFDT(SCSDT("BEGIN"),36500)
;
;;look for current asgn first
S SCX=$$TMPT(1)
S TMAIEN=$O(SCTMLIST("SCTM",SCTM,0))
I +TMAIEN S SCRESULT=1 G TMXISTQ
;
;;look for nearest future legit asgn/dschrg
S SCX=$$TMPT(0)
I '+$O(SCTMLIST("SCTM",SCTM,0)) G TMXISTQ
;
F S TMAIEN=$O(SCTMLIST("SCTM",SCTM,TMAIEN)) Q:'TMAIEN D
.S SCX=$O(SCTMLIST("SCTM",SCTM,TMAIEN,0))
.S SCX=$P(SCTMLIST(SCX),U,4,5)
.Q:$P(SCX,U,2)<+SCX
.S SCTMLIST("SCTM","BYDATE",+SCX,TMAIEN)=""
.Q
;
S SCX=$O(SCTMLIST("SCTM","BYDATE",""))
I +SCX D
.S TMAIEN=$O(SCTMLIST("SCTM","BYDATE",SCX,""))
.S SCRESULT=1
.Q
;
TMXISTQ S TMAIEN=+TMAIEN
Q +SCRESULT
;
TMPT(SCX) ;
S SCSDT("INCL")=SCX
K SCTMLIST
K SCTMERR
Q $$TMPT^SCAPMC(DFN,"SCSDT","","SCTMLIST","SCTMERR")
;
DELPOS(DISIEN,POSAIEN) ; DELETE a position
; DISIEN = SOURCE POSITION TO DISCHARGE
; POSAIEN = CURRENT DESTINATION POSITION IEN - USED JUST AS AN ERROR INDICATOR HERE
S DIK="^SCPT(404.43,"
S DA=DISIEN
;
IF DIK]"",$D(@(DIK_DA_",0)")) D ^DIK
E S POSAIEN=0_U_POSAIEN
Q
;
DISPOS(DISIEN,POSAIEN) ; DISCHARGE a position
; DISIEN = SOURCE POSITION TO DISCHARGE
; POSAIEN = CURRENT DESTINATION POSITION IEN - USED JUST AS AN ERROR INDICATOR HERE
N DISDAT
S DISDAT=SCACT ; init discharge date
I $P($G(^SCPT(404.43,DISIEN,0)),U,3)'>$$PREVDAY(SCACT) S DISDAT=$$PREVDAY(SCACT)
S STEC=$$INPTTP^SCAPMC(DFN,DISIEN,DISDAT,SCERR)
I 'STEC S POSAIEN=0_U_POSAIEN
Q
;
CREATPOS(POSAIEN,TMAIEN) ; CREATE A POSITION
N SCIEN
S POSAIEN="" ; initialize position IEN
IF $D(SCFIELDA) D
. S SCFLD=0
. F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
.. S SC($J,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
S SC($J,404.43,"+1,",.01)=TMAIEN
S SC($J,404.43,"+1,",.02)=SCTP
S SC($J,404.43,"+1,",.03)=SCACT
D UPDATE^DIE("","SC($J)","SCIEN",SCERR) ; create new position
IF $D(@SCERR) K SCIEN
ELSE D
. S POSAIEN=+$G(SCIEN(1))
. S SCNEWTP=1
. D AFTERTP^SCMCDD1(POSAIEN)
Q
;
DELTEAM(TMAIEN) ; DELETE A TEAM ASSIGNMENT
S DIK="^SCPT(404.42,"
S DA=TMAIEN
;
IF DIK]"",$D(@(DIK_DA_",0)")) D ^DIK
E S TMAIEN=0_U_TMAIEN
Q
;
DISTEAM(TMAIEN) ; DISCHARGE A TEAM ASSIGNMENT
; TMAIEN = SOURCE TEAM IEN
N DISDAT,SCPREVDT,SCNODE
S DISDAT=SCACT ; init discharge date
; discharge for previous day if assignment date prior to today
I $P($G(^SCPT(404.42,TMAIEN,0)),U,9)'>$$PREVDAY(SCACT) S DISDAT=$$PREVDAY(SCACT)
N SCTEC
S SCTEC=$$INPTTM^SCAPMC(DFN,TMAIEN,DISDAT,SCERR) ; Discharge from team Assignments
I 'SCTEC S TMAIEN=0_U_TMAIEN
Q
;
CREATETM(DFN,SCTMTO,SCACT,TMAIEN) ; CREATE A TEAM ASSIGNMENT
N SCTM,SCIEN
S TMAIEN="+1,"
; set team assignment type (i.e PC (1) or non-PC (99))
S:$D(@SCFIELDA@(.05)) SCTM($J,404.42,TMAIEN,.08)=$G(@SCMAINA@(.08),$S(@SCFIELDA@(.05):1,1:99))
; set team user entering
S:$D(@SCFIELDA@(.06)) SCTM($J,404.42,TMAIEN,.11)=$G(@SCMAINA@(.11),@SCFIELDA@(.06))
; set team Date/time entered
S:$D(@SCFIELDA@(.07)) SCTM($J,404.42,TMAIEN,.12)=$G(@SCMAINA@(.12),@SCFIELDA@(.07))
; set team last edited by
;S:$D(@SCFIELDA@(.08)) SCTM($J,404.42,TMAIEN,.13)=$G(@SCMAINA@(.13),@SCFIELDA@(.08))
; set team date/time last edited
;S:$D(@SCFIELDA@(.09)) SCTM($J,404.42,TMAIEN,.14)=$G(@SCMAINA@(.14),@SCFIELDA@(.09))
S SCTM($J,404.42,TMAIEN,.01)=DFN
S SCTM($J,404.42,TMAIEN,.02)=SCACT
S SCTM($J,404.42,TMAIEN,.03)=SCTMTO
D UPDATE^DIE("","SCTM($J)","SCIEN",SCERR) ; new entry
IF $D(@SCERR) D
. K SCIEN
. S TMAIEN=""
ELSE D
. S TMAIEN=$G(SCIEN(1)) ; new assignment record set up
. S SCNEWTM=1
. D AFTERTM^SCMCDD1(TMAIEN)
Q
;
TMACTIV(TMAIEN,PCPOS) ; CHANGE FUTURE ACTIVE DATE TO CURRENT DATE
; PCPOS - flag that indicates whether or not team should be activated as a PC Team
; the team definition is assumed to support PC service at this point
; also remove future discharge date if present
S SC($J,404.42,(+TMAIEN)_",",.14)=SCNOW ; date time last edited
S SC($J,404.42,(+TMAIEN)_",",.13)=DUZ ; last edited by
S SC($J,404.42,(+TMAIEN)_",",.02)=SCACT ; assigned date
S SC($J,404.42,(+TMAIEN)_",",.09)="" ; discharge date
I PCPOS S SC($J,404.42,(+TMAIEN)_",",.08)=1 ;
D FILE^DIE("","SC($J)",SCERR) ; update TEAM assignment
I $D(@SCERR) S TMAIEN=0_U_TMAIEN
Q
;
XALLPOS(FASIEN,POSAIEN) ; DISCHARGE ALL POSITIONS FROM THE "from" TEAM
; FASIEN = source position assignment IEN
; POSAIEN = destination position assignment IEN, used just for error reporting here
; this only occurs when the "from" pos and "to" pos are both Primary care,
; or the "from" team is PC and the "to" pos is PC.
; Rational is that a patient can't have more than one PC team
;
; use FASIEN to get team assignment, then find all positions for this team assignment,
; and discharge them
N POSASGN,TMASGN,DISDAT,SCX,SCFLAG
S DISDAT=SCACT ; init discharge date
; discharge for previous day if assignment date prior to today
S SCX=$$PREVDAY(SCACT)
I $P($G(^SCPT(404.43,FASIEN,0)),U,3)'>SCX S DISDAT=SCX
S SCFLAG=0
S TMASGN=+$P($G(^SCPT(404.43,FASIEN,0)),U,1)
I TMASGN D
.S POSASGN=0
.F S POSASGN=$O(^SCPT(404.43,"B",TMASGN,POSASGN)) Q:POSASGN="" D
..S SCX=+$P($G(^SCPT(404.43,POSASGN,0)),U,4) ;already discharged?
..I SCX,SCX<SCACT Q ;leave past alone!
..K @SCERR
..S STEC=$$INPTTP^SCAPMC(DFN,POSASGN,DISDAT,SCERR) ;discharge position
..I $D(@SCERR) S SCFLAG=1
..Q
.Q
I ('TMASGN)!(SCFLAG) S POSAIEN=0_U_POSAIEN
Q
;
GETPOSTM(POSAIEN) ; RETURN THE TEAM ASSIGNMENT FOR A POSITION
Q $P($G(^SCPT(404.43,POSAIEN,0)),U,1)
;
FUPOSASN(POSAIEN,SCACT) ; IS THIS A FUTURE POSITION ASSIGNMENT?
Q $P($G(^SCPT(404.43,POSAIEN,0)),U,3)>SCACT
;
FUTMASN(TMAIEN,SCACT) ; IS THIS A FUTURE TEAM ASSIGNMENT?
Q $P($G(^SCPT(404.42,TMAIEN,0)),U,2)>SCACT
;
FUTTMDIS(TMAIEN,SCACT) ; IS THERE A FUTURE TEAM DISCHARGE?
Q $P($G(^SCPT(404.42,TMAIEN,0)),U,9)>SCACT
;
DPOSPROB(SCPTTPA,SCACT) ; handle disposition of existing destination POSITION
I $$FUPOSASN(.SCPTTPA,SCACT) D Q:'SCPTTPA ; BAIL OUT
. D DELPOS(SCPTTPA,.SCPTTPA) ; DELETE future non-PC position assignment
. I 'SCPTTPA D ERROR^SCRPMPSP("Unable to DELETE non-PC position assignment for existing dest team",SCPTTPA,20) Q ; BAIL OUT
ELSE D
. D DISPOS(SCPTTPA,.SCPTTPA) ; else if current non-pc assignment discharge it
. I 'SCPTTPA D ERROR^SCRPMPSP("Unable to discharge non-PC position assignment with existing dest team",SCPTTPA,25) Q ; BAIL OUT
Q 'SCPTTPA
;
DTMPROB(SCPTTMA,SCACT) ; HANDLE DISPOSITION OF EXISTING DESTINATION TEAM
I $$FUTMASN(.SCPTTMA,SCACT) D Q:'SCPTTMA ; BAIL OUT
. D DELTEAM(.SCPTTMA) ; DELETE future dest NON-PC team assign
. I 'SCPTTMA D ERROR^SCRPMPSP("Unable to DELETE non-PC team assignment for existing dest team",SCPTTMA,30)
ELSE D
. D DISTEAM(.SCPTTMA) ; discharge current non-pc team assignment
. I 'SCPTTMA D ERROR^SCRPMPSP("Unable to discharge non-PC team assignment for existing dest team",SCPTTMA,35) Q ; BAIL OUT
Q 'SCPTTMA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPM21U 9445 printed Dec 13, 2024@02:42:36 Page 2
SCRPM21U ;ALB/PDR - POSITION REASSIGNMENT UTILITIES ; AUG 1998
+1 ;;5.3;Scheduling;**148,157**;Aug 13, 1993
+2 ;
PREVDAY(DAY) ; GET PREVIOUS DAY
+1 NEW X,X1,X2
+2 SET X1=DAY
SET X2=-1
+3 DO C^%DTC
+4 QUIT X
+5 ;
PCPCASN(FASIEN,SCTP) ; IS THIS A PRIMARY CARE to PRIMARY CARE ASSIGNMENT?
+1 ; FASIEN = Pointer to source Position assignment SCPT(404.43)
+2 ; SCTP = Destination position pointer to Position DEF file SCTM(404.57)
+3 NEW SPPC,DPPC,STPC,SCST
+4 ; Exclude the case where source = destination team
+5 ;
+6 ; pointer to position DEF file
SET SCST=$PIECE($GET(^SCPT(404.43,FASIEN,0)),U,2)
+7 ; pointer to team DEF file
SET SCST=$PIECE($GET(^SCTM(404.57,SCST,0)),U,2)
+8 ; this is really an error condition
IF SCST=""
QUIT 0
+9 ; source and dest teams are the same
IF SCST=$PIECE($GET(^SCTM(404.57,SCTP,0)),U,2)
QUIT 0
+10 ;
+11 ; Both source and destination positions are (or will be) primary care.
+12 ;
+13 ; test source position is a pc position, and the new position is too
+14 ; source position is primary care
SET SPPC=$PIECE($GET(^SCPT(404.43,FASIEN,0)),U,5)>0
+15 ; destination position is primary care
SET DPPC=@SCFIELDA@(.05)>0
+16 SET STPC=$$GETPOSTM(FASIEN)
+17 ; source team is primary care
SET STPC=$PIECE($GET(^SCPT(404.42,STPC,0)),U,8)=1
+18 ; if source pos and dest pos are PC OR source team and dest pos are PC then is a pc to pc assignment
+19 QUIT (SPPC&DPPC)!(STPC&DPPC)
+20 ;
UPDATPOS(POSAIEN,SCERR) ; UPDATE EXISTING POSITION ASSIGNMENT PARAMETERS, AND ENSURE NO FUTURE DISCHARGE
+1 NEW SC,SCFLD,ENTFLD
+2 SET ENTFLD=",.06,.07,"
+3 ; last edited by
SET SC($JOB,404.43,(+POSAIEN)_",",.08)=DUZ
+4 ; last edit date/time
SET SC($JOB,404.43,(+POSAIEN)_",",.09)=SCNOW
+5 ; set new activity date for existing position assgn
SET SC($JOB,404.43,(+POSAIEN)_",",.03)=SCACT
+6 ; ensure no future discharge
SET SC($JOB,404.43,(+POSAIEN)_",",.04)=""
+7 IF $DATA(SCFIELDA)
Begin DoDot:1
+8 SET SCFLD=0
+9 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:2
+10 ; don't want ENTRY user and ENTRY date time for edit
if ENTFLD[","_SCFLD_","
QUIT
+11 SET SC($JOB,404.43,(+POSAIEN)_",",SCFLD)=@SCFIELDA@(SCFLD)
End DoDot:2
End DoDot:1
+12 ; update position assignment paramaeters
DO FILE^DIE("","SC($J)",SCERR)
+13 IF $DATA(@SCERR)
SET POSAIEN=0_U_POSAIEN
+14 QUIT
+15 ;
TMEXIST(DFN,SCTM,SCSD,TMAIEN) ;
+1 ; returns 1 if current/future assignment exists else 0
+2 ; conserves IEN of the des tm asgn if it exists
+3 NEW SCRESULT,SCSDT,SCX,SCTMLIST,SCTMERR
+4 SET (SCRESULT,TMAIEN)=0
+5 ;
+6 ;;set date variables for $$tmpt
+7 SET SCSDT("BEGIN")=$GET(SCSD,DT)
+8 SET SCSDT("END")=$$FMADD^XLFDT(SCSDT("BEGIN"),36500)
+9 ;
+10 ;;look for current asgn first
+11 SET SCX=$$TMPT(1)
+12 SET TMAIEN=$ORDER(SCTMLIST("SCTM",SCTM,0))
+13 IF +TMAIEN
SET SCRESULT=1
GOTO TMXISTQ
+14 ;
+15 ;;look for nearest future legit asgn/dschrg
+16 SET SCX=$$TMPT(0)
+17 IF '+$ORDER(SCTMLIST("SCTM",SCTM,0))
GOTO TMXISTQ
+18 ;
+19 FOR
SET TMAIEN=$ORDER(SCTMLIST("SCTM",SCTM,TMAIEN))
if 'TMAIEN
QUIT
Begin DoDot:1
+20 SET SCX=$ORDER(SCTMLIST("SCTM",SCTM,TMAIEN,0))
+21 SET SCX=$PIECE(SCTMLIST(SCX),U,4,5)
+22 if $PIECE(SCX,U,2)<+SCX
QUIT
+23 SET SCTMLIST("SCTM","BYDATE",+SCX,TMAIEN)=""
+24 QUIT
End DoDot:1
+25 ;
+26 SET SCX=$ORDER(SCTMLIST("SCTM","BYDATE",""))
+27 IF +SCX
Begin DoDot:1
+28 SET TMAIEN=$ORDER(SCTMLIST("SCTM","BYDATE",SCX,""))
+29 SET SCRESULT=1
+30 QUIT
End DoDot:1
+31 ;
TMXISTQ SET TMAIEN=+TMAIEN
+1 QUIT +SCRESULT
+2 ;
TMPT(SCX) ;
+1 SET SCSDT("INCL")=SCX
+2 KILL SCTMLIST
+3 KILL SCTMERR
+4 QUIT $$TMPT^SCAPMC(DFN,"SCSDT","","SCTMLIST","SCTMERR")
+5 ;
DELPOS(DISIEN,POSAIEN) ; DELETE a position
+1 ; DISIEN = SOURCE POSITION TO DISCHARGE
+2 ; POSAIEN = CURRENT DESTINATION POSITION IEN - USED JUST AS AN ERROR INDICATOR HERE
+3 SET DIK="^SCPT(404.43,"
+4 SET DA=DISIEN
+5 ;
+6 IF DIK]""
IF $DATA(@(DIK_DA_",0)"))
DO ^DIK
+7 IF '$TEST
SET POSAIEN=0_U_POSAIEN
+8 QUIT
+9 ;
DISPOS(DISIEN,POSAIEN) ; DISCHARGE a position
+1 ; DISIEN = SOURCE POSITION TO DISCHARGE
+2 ; POSAIEN = CURRENT DESTINATION POSITION IEN - USED JUST AS AN ERROR INDICATOR HERE
+3 NEW DISDAT
+4 ; init discharge date
SET DISDAT=SCACT
+5 IF $PIECE($GET(^SCPT(404.43,DISIEN,0)),U,3)'>$$PREVDAY(SCACT)
SET DISDAT=$$PREVDAY(SCACT)
+6 SET STEC=$$INPTTP^SCAPMC(DFN,DISIEN,DISDAT,SCERR)
+7 IF 'STEC
SET POSAIEN=0_U_POSAIEN
+8 QUIT
+9 ;
CREATPOS(POSAIEN,TMAIEN) ; CREATE A POSITION
+1 NEW SCIEN
+2 ; initialize position IEN
SET POSAIEN=""
+3 IF $DATA(SCFIELDA)
Begin DoDot:1
+4 SET SCFLD=0
+5 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:2
+6 SET SC($JOB,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
End DoDot:2
End DoDot:1
+7 SET SC($JOB,404.43,"+1,",.01)=TMAIEN
+8 SET SC($JOB,404.43,"+1,",.02)=SCTP
+9 SET SC($JOB,404.43,"+1,",.03)=SCACT
+10 ; create new position
DO UPDATE^DIE("","SC($J)","SCIEN",SCERR)
+11 IF $DATA(@SCERR)
KILL SCIEN
+12 IF '$TEST
Begin DoDot:1
+13 SET POSAIEN=+$GET(SCIEN(1))
+14 SET SCNEWTP=1
+15 DO AFTERTP^SCMCDD1(POSAIEN)
End DoDot:1
+16 QUIT
+17 ;
DELTEAM(TMAIEN) ; DELETE A TEAM ASSIGNMENT
+1 SET DIK="^SCPT(404.42,"
+2 SET DA=TMAIEN
+3 ;
+4 IF DIK]""
IF $DATA(@(DIK_DA_",0)"))
DO ^DIK
+5 IF '$TEST
SET TMAIEN=0_U_TMAIEN
+6 QUIT
+7 ;
DISTEAM(TMAIEN) ; DISCHARGE A TEAM ASSIGNMENT
+1 ; TMAIEN = SOURCE TEAM IEN
+2 NEW DISDAT,SCPREVDT,SCNODE
+3 ; init discharge date
SET DISDAT=SCACT
+4 ; discharge for previous day if assignment date prior to today
+5 IF $PIECE($GET(^SCPT(404.42,TMAIEN,0)),U,9)'>$$PREVDAY(SCACT)
SET DISDAT=$$PREVDAY(SCACT)
+6 NEW SCTEC
+7 ; Discharge from team Assignments
SET SCTEC=$$INPTTM^SCAPMC(DFN,TMAIEN,DISDAT,SCERR)
+8 IF 'SCTEC
SET TMAIEN=0_U_TMAIEN
+9 QUIT
+10 ;
CREATETM(DFN,SCTMTO,SCACT,TMAIEN) ; CREATE A TEAM ASSIGNMENT
+1 NEW SCTM,SCIEN
+2 SET TMAIEN="+1,"
+3 ; set team assignment type (i.e PC (1) or non-PC (99))
+4 if $DATA(@SCFIELDA@(.05))
SET SCTM($JOB,404.42,TMAIEN,.08)=$GET(@SCMAINA@(.08),$SELECT(@SCFIELDA@(.05):1,1:99))
+5 ; set team user entering
+6 if $DATA(@SCFIELDA@(.06))
SET SCTM($JOB,404.42,TMAIEN,.11)=$GET(@SCMAINA@(.11),@SCFIELDA@(.06))
+7 ; set team Date/time entered
+8 if $DATA(@SCFIELDA@(.07))
SET SCTM($JOB,404.42,TMAIEN,.12)=$GET(@SCMAINA@(.12),@SCFIELDA@(.07))
+9 ; set team last edited by
+10 ;S:$D(@SCFIELDA@(.08)) SCTM($J,404.42,TMAIEN,.13)=$G(@SCMAINA@(.13),@SCFIELDA@(.08))
+11 ; set team date/time last edited
+12 ;S:$D(@SCFIELDA@(.09)) SCTM($J,404.42,TMAIEN,.14)=$G(@SCMAINA@(.14),@SCFIELDA@(.09))
+13 SET SCTM($JOB,404.42,TMAIEN,.01)=DFN
+14 SET SCTM($JOB,404.42,TMAIEN,.02)=SCACT
+15 SET SCTM($JOB,404.42,TMAIEN,.03)=SCTMTO
+16 ; new entry
DO UPDATE^DIE("","SCTM($J)","SCIEN",SCERR)
+17 IF $DATA(@SCERR)
Begin DoDot:1
+18 KILL SCIEN
+19 SET TMAIEN=""
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 ; new assignment record set up
SET TMAIEN=$GET(SCIEN(1))
+22 SET SCNEWTM=1
+23 DO AFTERTM^SCMCDD1(TMAIEN)
End DoDot:1
+24 QUIT
+25 ;
TMACTIV(TMAIEN,PCPOS) ; CHANGE FUTURE ACTIVE DATE TO CURRENT DATE
+1 ; PCPOS - flag that indicates whether or not team should be activated as a PC Team
+2 ; the team definition is assumed to support PC service at this point
+3 ; also remove future discharge date if present
+4 ; date time last edited
SET SC($JOB,404.42,(+TMAIEN)_",",.14)=SCNOW
+5 ; last edited by
SET SC($JOB,404.42,(+TMAIEN)_",",.13)=DUZ
+6 ; assigned date
SET SC($JOB,404.42,(+TMAIEN)_",",.02)=SCACT
+7 ; discharge date
SET SC($JOB,404.42,(+TMAIEN)_",",.09)=""
+8 ;
IF PCPOS
SET SC($JOB,404.42,(+TMAIEN)_",",.08)=1
+9 ; update TEAM assignment
DO FILE^DIE("","SC($J)",SCERR)
+10 IF $DATA(@SCERR)
SET TMAIEN=0_U_TMAIEN
+11 QUIT
+12 ;
XALLPOS(FASIEN,POSAIEN) ; DISCHARGE ALL POSITIONS FROM THE "from" TEAM
+1 ; FASIEN = source position assignment IEN
+2 ; POSAIEN = destination position assignment IEN, used just for error reporting here
+3 ; this only occurs when the "from" pos and "to" pos are both Primary care,
+4 ; or the "from" team is PC and the "to" pos is PC.
+5 ; Rational is that a patient can't have more than one PC team
+6 ;
+7 ; use FASIEN to get team assignment, then find all positions for this team assignment,
+8 ; and discharge them
+9 NEW POSASGN,TMASGN,DISDAT,SCX,SCFLAG
+10 ; init discharge date
SET DISDAT=SCACT
+11 ; discharge for previous day if assignment date prior to today
+12 SET SCX=$$PREVDAY(SCACT)
+13 IF $PIECE($GET(^SCPT(404.43,FASIEN,0)),U,3)'>SCX
SET DISDAT=SCX
+14 SET SCFLAG=0
+15 SET TMASGN=+$PIECE($GET(^SCPT(404.43,FASIEN,0)),U,1)
+16 IF TMASGN
Begin DoDot:1
+17 SET POSASGN=0
+18 FOR
SET POSASGN=$ORDER(^SCPT(404.43,"B",TMASGN,POSASGN))
if POSASGN=""
QUIT
Begin DoDot:2
+19 ;already discharged?
SET SCX=+$PIECE($GET(^SCPT(404.43,POSASGN,0)),U,4)
+20 ;leave past alone!
IF SCX
IF SCX<SCACT
QUIT
+21 KILL @SCERR
+22 ;discharge position
SET STEC=$$INPTTP^SCAPMC(DFN,POSASGN,DISDAT,SCERR)
+23 IF $DATA(@SCERR)
SET SCFLAG=1
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 IF ('TMASGN)!(SCFLAG)
SET POSAIEN=0_U_POSAIEN
+27 QUIT
+28 ;
GETPOSTM(POSAIEN) ; RETURN THE TEAM ASSIGNMENT FOR A POSITION
+1 QUIT $PIECE($GET(^SCPT(404.43,POSAIEN,0)),U,1)
+2 ;
FUPOSASN(POSAIEN,SCACT) ; IS THIS A FUTURE POSITION ASSIGNMENT?
+1 QUIT $PIECE($GET(^SCPT(404.43,POSAIEN,0)),U,3)>SCACT
+2 ;
FUTMASN(TMAIEN,SCACT) ; IS THIS A FUTURE TEAM ASSIGNMENT?
+1 QUIT $PIECE($GET(^SCPT(404.42,TMAIEN,0)),U,2)>SCACT
+2 ;
FUTTMDIS(TMAIEN,SCACT) ; IS THERE A FUTURE TEAM DISCHARGE?
+1 QUIT $PIECE($GET(^SCPT(404.42,TMAIEN,0)),U,9)>SCACT
+2 ;
DPOSPROB(SCPTTPA,SCACT) ; handle disposition of existing destination POSITION
+1 ; BAIL OUT
IF $$FUPOSASN(.SCPTTPA,SCACT)
Begin DoDot:1
+2 ; DELETE future non-PC position assignment
DO DELPOS(SCPTTPA,.SCPTTPA)
+3 ; BAIL OUT
IF 'SCPTTPA
DO ERROR^SCRPMPSP("Unable to DELETE non-PC position assignment for existing dest team",SCPTTPA,20)
QUIT
End DoDot:1
if 'SCPTTPA
QUIT
+4 IF '$TEST
Begin DoDot:1
+5 ; else if current non-pc assignment discharge it
DO DISPOS(SCPTTPA,.SCPTTPA)
+6 ; BAIL OUT
IF 'SCPTTPA
DO ERROR^SCRPMPSP("Unable to discharge non-PC position assignment with existing dest team",SCPTTPA,25)
QUIT
End DoDot:1
+7 QUIT 'SCPTTPA
+8 ;
DTMPROB(SCPTTMA,SCACT) ; HANDLE DISPOSITION OF EXISTING DESTINATION TEAM
+1 ; BAIL OUT
IF $$FUTMASN(.SCPTTMA,SCACT)
Begin DoDot:1
+2 ; DELETE future dest NON-PC team assign
DO DELTEAM(.SCPTTMA)
+3 IF 'SCPTTMA
DO ERROR^SCRPMPSP("Unable to DELETE non-PC team assignment for existing dest team",SCPTTMA,30)
End DoDot:1
if 'SCPTTMA
QUIT
+4 IF '$TEST
Begin DoDot:1
+5 ; discharge current non-pc team assignment
DO DISTEAM(.SCPTTMA)
+6 ; BAIL OUT
IF 'SCPTTMA
DO ERROR^SCRPMPSP("Unable to discharge non-PC team assignment for existing dest team",SCPTTMA,35)
QUIT
End DoDot:1
+7 QUIT 'SCPTTMA
