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

SCMCTMU.m

Go to the documentation of this file. 
  1. SCMCTMU ;ALB/REW - Team-Patient Utilities ; 1 May 95
  1.  ;;5.3;Scheduling;**41**;AUG 13, 1993
  1.  ;1
  1. ACTTM(SCTM,SCDT) ;is the team  currently active?
  1.  ; Used by computed field #300 (CURRENTLY ACTIVE?) OF file #404.51
  1.  ; Input:
  1.  ;  SCTM  - Pointer to Team file #404.51
  1.  ;  SCDT  - Date to check for, Default=DT
  1.  ; Returns:
  1.  ;   1  if after effective date and before inactive date
  1.  ;   0  if not yet active or inactivated
  1.  ;   -1 if error
  1.  ;
  1.  Q $$DATES^SCAPMCU1(404.58,.SCTM,.SCDT)
  1.  ;
  1. ENROLL(DFN,CLINIC,DATE) ;is this patient enrolled in this clinic on a date?
  1.  ;Input:
  1.  ;    DFN - ien of Patient file
  1.  ; CLINIC - Pointer to file 44
  1.  ;   DATE - (Optional) Effective Date, default=DT
  1.  ;Return: [1|Yes, he is enrolled;0|he is not]
  1.  ;
  1.  N SCCL,SCL1,SCNODE,SCACT,SCINACT,SCYES
  1.  S SCYES=0
  1.  S SCCL=0
  1.  F  S SCCL=$O(^DPT(DFN,"DE","B",CLINIC,SCCL)) Q:'SCCL  D
  1.  .S SCCL1=0
  1.  .F  S SCCL1=$O(^DPT(DFN,"DE",SCCL,1,SCCL1)) Q:'SCCL1  D
  1.  ..S SCNODE=$G(^DPT(DFN,"DE",SCCL,1,SCCL1,0))
  1.  ..S SCACT=+SCNODE
  1.  ..S SCINACT=$P(SCNODE,U,3)
  1.  ..S:$S('SCACT:0,(SCACT>DATE):0,'SCINACT:1,(SCINACT<DATE):0,1:1) SCYES=1
  1.  Q SCYES
  1.  ;
  1. RESTCONS(DFN) ;does this patient have restricted consults?
  1.  ; for a clinic in which the patient is NOT enrolled, some patients/teams
  1.  ; require more authority to enroll or make appointments
  1.  ; this will often be used with $$ENROLL(dfn) to see if he is enrolled
  1.  ;
  1.  ; Input: DFN - ien of Patient File
  1.  ; Return: [1|Yes, restrict 0|No
  1.  Q 1
  1. WHOCLIN(SDCL,DATE) ;give clinic & date return prt to 200
  1.  ; SDCL - ien of #44
  1.  ; DATE - effective date (optional) default =DT
  1.  ; Returned: ien of 200
  1.  ;
  1.  Q
  1. POSCLIN(SDCL,DATE) ;given clinic & date, return ptr to team position 404.57
  1.  ;  SDCL - ien of Hospital Location (#44)
  1.  ;  Returned: If exactly one position for clinic - ien of team postion
  1.  ;            else null
  1.  ;
  1.  N X,SCD
  1.  S:'$G(DATE) DATE=DT
  1.  S SCD=$O(^SCTM(404.57,"ACLINDT",+SDCL,-DATE)) ;SCD is the effective date
  1.  S X=$O(^SCTM(404.57,"ACLINDT",+SDCL,+SCD,"")) ;position assoc w/ clinic
  1.  Q $G(X)
  1. WHOPOS(SCTP,DATE) ;given position & date,return pointer to 200^name of pr
  1.  ;SCTP - ien of Team Position File (#404.57)
  1.  ; Date - (Optional) effective date - default=today
  1.  ;
  1.  Q $$GETPRTP^SCAPMCU2(SCTP,.DATE)
  1. DISPWHO(SCPOS,DATE) ;given position & date, return external of 200
  1.  ;SCPOS - ien of 404.48)
  1.  ; DATE - (Optional) effective date - default=today
  1.  ;
  1.  N Y,SCP
  1.  S:'$G(DATE) DATE=DT
  1.  S SCP=$$WHOPOS(SCPOS,DATE)
  1.  S:SCP Y=$S($D(^VA(200,+SCP,0)):$P(^(0),U,1),1:"Unknown")
  1.  Q $G(Y)
  1. PR(SDNPI) ;Provider Display Data
  1.  ; Input  -- SDNPI    New Person IEN
  1.  ; Output -- Provider Display Data - Provider Name
  1.  N Y
  1.  S Y=$S($D(^VA(200,SDNPI,0)):$P(^(0),"^"),1:"Unknown")
  1.  Q $G(Y)
  1. PTTMSCRN ;define dic('s') to ensure patient team position assignement is ok
  1.  ;
  1. CK N SCTM,SCTMA
  1.  S SCTMA=$P($G(^SCPT(404.43,Y,0)),U,1)
  1.  S SCTM=$P($G(^SCPT(404.42,SCTMA,0)),U,3)
  1.  S DIC("S")="IF $D(^SCTM(404.57,""C"","_SCTM_",Y))"
  1.  Q
  1. OKPTTM(SCNODE,DA) ;check pt team assignment - 404.42
  1.  ; SCNODE is proposed new node
  1.  Q 1
  1.  N OK,DFN,SCTM,SCACT,SCINACT,SCDTS,SCTMHIST,SCB4,SCAFT
  1.  S OK=1
  1.  G:'DA QTOKTM
  1.  S DFN=$P(SCNODE,U,1)
  1.  S SCTM=$P(SCNODE,U,3)
  1.  S SCACT=$P(SCNODE,U,2)
  1.  S SCINACT=$P(SCNODE,U,9)
  1.  S:$G(SCACT) SCDTS("BEGIN")=SCACT
  1.  S:$D(SCACT) SCDTS("END")=$S(SCINACT:SCINACT,1:3990101)
  1.  S:$D(SCDTS) SCDTS("INCL")=1
  1.  ;check patient (.01) - none now
  1.  ;check team (.03)
  1.  IF SCINACT&('SCACT) S OK=0_U_"Activation must be defined before Discharge" G QTOKTM
  1.  IF SCTM&SCACT&DFN D
  1.  .S SCTMHIST=$$ACTHIST^SCAPMCU2(404.58,.SCTM,.SCDTS)
  1.  .S:'SCTMHIST OK=0_U_"Team Not Active"
  1.  .;check assignment dt (.02)
  1.  .;  - is there an assignment on exactly the same date in 404.42?
  1.  .S SCPTTMA=0 F  S SCPTTMA=$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,SCPTTMA)) Q:SCPTTMA=""!(SCPTTMA=DA)!(DA="")  S OK=0_U_"Already an activation for patient/team on this date"
  1.  .;  - is there an assignment w/o a discharge before in 404.42?
  1.  .S SCB4=$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT))
  1.  .S SCB4A=$O(^SCPT(404.42,"AIDT",DFN,SCTM,+SCB4,0))
  1.  .S:SCB4A&('$P($G(^SCPT(404.42,+SCB4A,0)),U,9)) OK=0_U_"Existing active patient/team assignment already"
  1.  .;check inactivation dt (.09)
  1.  .;  - if exists, is inactivation after assignment dt
  1.  .S:SCINACT&(SCACT'<SCINACT) OK=0_U_"Activation must be before discharge"
  1.  .;  - if there is a future assignment is it after this inactivation?
  1.  .S SCAFT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCINACT),-1)
  1.  .S:SCAFT&(SCAFT'>SCINACT) OK=0_U_"Existing future activation before this inactivation"
  1. QTOKTM Q OK
  1.  ;
  1. INSTPCTM(DFN,SCEFF) ;return institution & team for pt's pc team
  1.  ; return ptr4^institution^sctm^team name
  1.  N SCTM,SCINST,SCOK
  1.  S SCOK=0
  1.  S SCTM=+$$GETPCTM^SCAPMCU2(.DFN,.SCEFF,1)
  1.  S SCINST=+$P($G(^SCTM(404.51,+$G(SCTM),0)),U,7)
  1.  S:SCTM&SCINST SCOK=1
  1.  Q $S('SCOK:0,1:SCTM_U_$P($G(^SCTM(404.51,SCTM,0)),U,1)_U_SCINST_U_$P($G(^DIC(4,SCINST,0)),U,1))
  1.  ;
  1. EVT(SCCVEVT,SCCVORG) ;Invoke encounter conversion event driver
  1.  ; Input  -- SCCVEVT  Conversion event
  1.  ;                    0=Estimate, 1=Convert, 2=Re-convert
  1.  ;           SCCVORG  Originating process type
  1.  ; Output -- ^TMP("SCCVEVT",$J, disposition array
  1.  K DTOUT,DIROUT
  1.  S X=+$O(^ORD(101,"B","SCMC ENCOUNTER CONVERSION EVENTS",0))_";ORD(101,"
  1.  I X D EN^XQOR
  1.  K X,^TMP("SCCVEVT",$J)
  1. EVTQ Q