- 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 Feb 19, 2025@00:07:51 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
