SCMCTMU2 ;ALB/REW - Team-Patient Utilities ; 1 Apr 96
;;5.3;Scheduling;**41,51,148**;AUG 13, 1993
;1
RESTENR ;call when pt is set to 'restrict consults' & he is enrolled in clinic
G:'$G(DFN) END
S SCCL=0
F S SCCL=$O(^TMP($J,"SC CED","AFTER","B",SCCL)) Q:'SCCL D
.W !,SCCL
END Q
;
YSPTTMPC(DFN,SCACT) ;is it ok to give patient a new pc team?
; Return [OK:1,Not OK: 0^Message]
N SCOK,SCX,SCTM
;does pt have a current pc team?
S SCTM=$$GETPCTM^SCAPMCU2(DFN,DT,1)
IF SCTM>0 S SCOK="0^Pt has current PC Team Assignment"_U_SCTM G QTOKPC
;does pt have a future pc team?
S SCX=$O(^SCPT(404.42,"APCTM",DFN,1,SCACT))
IF SCX D G QTOKPC
.S SCTM=$O(^SCPT(404.42,"APCTM",DFN,1,+SCX,0))
.S SCOK="0^Patient has future PC Assignment to the "_$P($G(^SCTM(404.51,+SCTM,0)),U,1)_" team."_U_SCTM
S SCOK=1
QTOKPC Q SCOK
;
OKACPTTM(DFN,SCTM,SCDATE,SCACTIVE) ;is patient active from now till forever?
; Returned: 1: Not active from now till forever, 0 = Active sometime
; DFN - Pointer to Patient File
; SCTM - Team File ien of interest
; SCDATE - Start Date
; SCACTIVE- Must Team be active on date or just sometime in future?
N SCTMDT,SCOK,SCACERR,SCACLST
S SCOK=1
S SCTMDT("BEGIN")=$G(SCDATE,DT)
S SCTMDT("END")=3990101 ;forever
S SCTMDT("INCL")=0
S SCACTIVE=$G(SCACTIVE,1)
; if checking for active teams
IF SCACTIVE&('$$ACTHIST^SCAPMCU2(404.58,.SCTM,.SCTMDT,"SCACERR","SCACLST")) S SCOK=0 G ENDOKTM
S SCOK=$$TMPT^SCAPMC(DFN,"SCTMDT",,"SCACLST","SCACERR")
S:SCOK>0&($D(SCACLST("SCTM",SCTM))) SCOK=0
ENDOKTM Q SCOK
;
OKPTTMPC(DFN,SCTM,DATE) ;
N SCOK,SCPCTM
S SCOK=1
;is this a possible pc team?
IF '$P($G(^SCTM(404.51,+$G(SCTM),0)),U,5) S SCOK=0 G QTOKTM
S SCPCTM=$$GETPCTM^SCAPMCU2(DFN,DATE,1)
IF SCPCTM D G QTOKTM
.IF SCPCTM'=SCTM D
..S SCOK=0
ELSE D
.S SCOK=$$YSPTTMPC(DFN,DATE)
QTOKTM Q SCOK
;
OKINPTTM(DFN,SCTM,SCINACT) ;no future pt-position assignments?
Q:'($G(DFN)&($G(SCTM))&($G(SCINACT))) 0
N SCTP,SCPTTPDT,SCPTTPI,SCPTTP0,OK
S SCTP=0,OK=1
F S SCTP=$O(^SCPT(404.43,"ADFN",DFN,SCTP)) Q:'SCTP D Q:'OK
.F SCPTTPDT=0:0 S SCPTTPDT=$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCPTTPDT)) Q:'SCPTTPDT D
..S SCPTTPI=$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCPTTPDT,0))
..S SCPTTP0=$G(^SCPT(404.43,SCPTTPI,0))
..Q:$P($G(^SCTM(404.57,+$P(SCPTTP0,U,2),0)),U,2)'=SCTM ;ignore other teams
..S:'$P(SCPTTP0,U,4) OK=0 ;all ptpos assignments must have inact date
..S:$P(SCPTTP0,U,4)>SCINACT OK=0 ;all ptpos inact dates after tm inact
Q OK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTMU2 2541 printed Sep 15, 2024@22:05:25 Page 2
SCMCTMU2 ;ALB/REW - Team-Patient Utilities ; 1 Apr 96
+1 ;;5.3;Scheduling;**41,51,148**;AUG 13, 1993
+2 ;1
RESTENR ;call when pt is set to 'restrict consults' & he is enrolled in clinic
+1 if '$GET(DFN)
GOTO END
+2 SET SCCL=0
+3 FOR
SET SCCL=$ORDER(^TMP($JOB,"SC CED","AFTER","B",SCCL))
if 'SCCL
QUIT
Begin DoDot:1
+4 WRITE !,SCCL
End DoDot:1
END QUIT
+1 ;
YSPTTMPC(DFN,SCACT) ;is it ok to give patient a new pc team?
+1 ; Return [OK:1,Not OK: 0^Message]
+2 NEW SCOK,SCX,SCTM
+3 ;does pt have a current pc team?
+4 SET SCTM=$$GETPCTM^SCAPMCU2(DFN,DT,1)
+5 IF SCTM>0
SET SCOK="0^Pt has current PC Team Assignment"_U_SCTM
GOTO QTOKPC
+6 ;does pt have a future pc team?
+7 SET SCX=$ORDER(^SCPT(404.42,"APCTM",DFN,1,SCACT))
+8 IF SCX
Begin DoDot:1
+9 SET SCTM=$ORDER(^SCPT(404.42,"APCTM",DFN,1,+SCX,0))
+10 SET SCOK="0^Patient has future PC Assignment to the "_$PIECE($GET(^SCTM(404.51,+SCTM,0)),U,1)_" team."_U_SCTM
End DoDot:1
GOTO QTOKPC
+11 SET SCOK=1
QTOKPC QUIT SCOK
+1 ;
OKACPTTM(DFN,SCTM,SCDATE,SCACTIVE) ;is patient active from now till forever?
+1 ; Returned: 1: Not active from now till forever, 0 = Active sometime
+2 ; DFN - Pointer to Patient File
+3 ; SCTM - Team File ien of interest
+4 ; SCDATE - Start Date
+5 ; SCACTIVE- Must Team be active on date or just sometime in future?
+6 NEW SCTMDT,SCOK,SCACERR,SCACLST
+7 SET SCOK=1
+8 SET SCTMDT("BEGIN")=$GET(SCDATE,DT)
+9 ;forever
SET SCTMDT("END")=3990101
+10 SET SCTMDT("INCL")=0
+11 SET SCACTIVE=$GET(SCACTIVE,1)
+12 ; if checking for active teams
+13 IF SCACTIVE&('$$ACTHIST^SCAPMCU2(404.58,.SCTM,.SCTMDT,"SCACERR","SCACLST"))
SET SCOK=0
GOTO ENDOKTM
+14 SET SCOK=$$TMPT^SCAPMC(DFN,"SCTMDT",,"SCACLST","SCACERR")
+15 if SCOK>0&($DATA(SCACLST("SCTM",SCTM)))
SET SCOK=0
ENDOKTM QUIT SCOK
+1 ;
OKPTTMPC(DFN,SCTM,DATE) ;
+1 NEW SCOK,SCPCTM
+2 SET SCOK=1
+3 ;is this a possible pc team?
+4 IF '$PIECE($GET(^SCTM(404.51,+$GET(SCTM),0)),U,5)
SET SCOK=0
GOTO QTOKTM
+5 SET SCPCTM=$$GETPCTM^SCAPMCU2(DFN,DATE,1)
+6 IF SCPCTM
Begin DoDot:1
+7 IF SCPCTM'=SCTM
Begin DoDot:2
+8 SET SCOK=0
End DoDot:2
End DoDot:1
GOTO QTOKTM
+9 IF '$TEST
Begin DoDot:1
+10 SET SCOK=$$YSPTTMPC(DFN,DATE)
End DoDot:1
QTOKTM QUIT SCOK
+1 ;
OKINPTTM(DFN,SCTM,SCINACT) ;no future pt-position assignments?
+1 if '($GET(DFN)&($GET(SCTM))&($GET(SCINACT)))
QUIT 0
+2 NEW SCTP,SCPTTPDT,SCPTTPI,SCPTTP0,OK
+3 SET SCTP=0
SET OK=1
+4 FOR
SET SCTP=$ORDER(^SCPT(404.43,"ADFN",DFN,SCTP))
if 'SCTP
QUIT
Begin DoDot:1
+5 FOR SCPTTPDT=0:0
SET SCPTTPDT=$ORDER(^SCPT(404.43,"ADFN",DFN,SCTP,SCPTTPDT))
if 'SCPTTPDT
QUIT
Begin DoDot:2
+6 SET SCPTTPI=$ORDER(^SCPT(404.43,"ADFN",DFN,SCTP,SCPTTPDT,0))
+7 SET SCPTTP0=$GET(^SCPT(404.43,SCPTTPI,0))
+8 ;ignore other teams
if $PIECE($GET(^SCTM(404.57,+$PIECE(SCPTTP0,U,2),0)),U,2)'=SCTM
QUIT
+9 ;all ptpos assignments must have inact date
if '$PIECE(SCPTTP0,U,4)
SET OK=0
+10 ;all ptpos inact dates after tm inact
if $PIECE(SCPTTP0,U,4)>SCINACT
SET OK=0
End DoDot:2
End DoDot:1
if 'OK
QUIT
+11 QUIT OK
