Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCMCTMU2

SCMCTMU2.m

Go to the documentation of this file.
  1. SCMCTMU2 ;ALB/REW - Team-Patient Utilities ; 1 Apr 96
  1. ;;5.3;Scheduling;**41,51,148**;AUG 13, 1993
  1. ;1
  1. RESTENR ;call when pt is set to 'restrict consults' & he is enrolled in clinic
  1. G:'$G(DFN) END
  1. S SCCL=0
  1. F S SCCL=$O(^TMP($J,"SC CED","AFTER","B",SCCL)) Q:'SCCL D
  1. .W !,SCCL
  1. END Q
  1. ;
  1. YSPTTMPC(DFN,SCACT) ;is it ok to give patient a new pc team?
  1. ; Return [OK:1,Not OK: 0^Message]
  1. N SCOK,SCX,SCTM
  1. ;does pt have a current pc team?
  1. S SCTM=$$GETPCTM^SCAPMCU2(DFN,DT,1)
  1. IF SCTM>0 S SCOK="0^Pt has current PC Team Assignment"_U_SCTM G QTOKPC
  1. ;does pt have a future pc team?
  1. S SCX=$O(^SCPT(404.42,"APCTM",DFN,1,SCACT))
  1. IF SCX D G QTOKPC
  1. .S SCTM=$O(^SCPT(404.42,"APCTM",DFN,1,+SCX,0))
  1. .S SCOK="0^Patient has future PC Assignment to the "_$P($G(^SCTM(404.51,+SCTM,0)),U,1)_" team."_U_SCTM
  1. S SCOK=1
  1. QTOKPC Q SCOK
  1. ;
  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
  1. ; DFN - Pointer to Patient File
  1. ; SCTM - Team File ien of interest
  1. ; SCDATE - Start Date
  1. ; SCACTIVE- Must Team be active on date or just sometime in future?
  1. N SCTMDT,SCOK,SCACERR,SCACLST
  1. S SCOK=1
  1. S SCTMDT("BEGIN")=$G(SCDATE,DT)
  1. S SCTMDT("END")=3990101 ;forever
  1. S SCTMDT("INCL")=0
  1. S SCACTIVE=$G(SCACTIVE,1)
  1. ; if checking for active teams
  1. IF SCACTIVE&('$$ACTHIST^SCAPMCU2(404.58,.SCTM,.SCTMDT,"SCACERR","SCACLST")) S SCOK=0 G ENDOKTM
  1. S SCOK=$$TMPT^SCAPMC(DFN,"SCTMDT",,"SCACLST","SCACERR")
  1. S:SCOK>0&($D(SCACLST("SCTM",SCTM))) SCOK=0
  1. ENDOKTM Q SCOK
  1. ;
  1. OKPTTMPC(DFN,SCTM,DATE) ;
  1. N SCOK,SCPCTM
  1. S SCOK=1
  1. ;is this a possible pc team?
  1. IF '$P($G(^SCTM(404.51,+$G(SCTM),0)),U,5) S SCOK=0 G QTOKTM
  1. S SCPCTM=$$GETPCTM^SCAPMCU2(DFN,DATE,1)
  1. IF SCPCTM D G QTOKTM
  1. .IF SCPCTM'=SCTM D
  1. ..S SCOK=0
  1. ELSE D
  1. .S SCOK=$$YSPTTMPC(DFN,DATE)
  1. QTOKTM Q SCOK
  1. ;
  1. OKINPTTM(DFN,SCTM,SCINACT) ;no future pt-position assignments?
  1. Q:'($G(DFN)&($G(SCTM))&($G(SCINACT))) 0
  1. N SCTP,SCPTTPDT,SCPTTPI,SCPTTP0,OK
  1. S SCTP=0,OK=1
  1. F S SCTP=$O(^SCPT(404.43,"ADFN",DFN,SCTP)) Q:'SCTP D Q:'OK
  1. .F SCPTTPDT=0:0 S SCPTTPDT=$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCPTTPDT)) Q:'SCPTTPDT D
  1. ..S SCPTTPI=$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCPTTPDT,0))
  1. ..S SCPTTP0=$G(^SCPT(404.43,SCPTTPI,0))
  1. ..Q:$P($G(^SCTM(404.57,+$P(SCPTTP0,U,2),0)),U,2)'=SCTM ;ignore other teams
  1. ..S:'$P(SCPTTP0,U,4) OK=0 ;all ptpos assignments must have inact date
  1. ..S:$P(SCPTTP0,U,4)>SCINACT OK=0 ;all ptpos inact dates after tm inact
  1. Q OK