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

SCMCTPU.m

Go to the documentation of this file.
  1. SCMCTPU ;ALB/REW - Team Position Utilities ; 9 Jun 1995
  1. ;;5.3;Scheduling;**41,130**;AUG 13, 1993
  1. ;1
  1. ACTPTTM(SCPTTM,SCDT) ;is the patient- team assignment currently active?
  1. ; Used by computed field #300 (CURRENTLY ACTIVE?) OF file #404.57
  1. ; Input:
  1. ; SCPTTM - Pointer to Patient Team Assignment file -404.42
  1. ; SCDT - Date to check for, Default=DT
  1. ; Returns
  1. ; status^status change date
  1. ; status:
  1. ; 1 if after effective date and before inactive date
  1. ; 0 if not yet active or inactivated already
  1. ; -1 if error
  1. ;999
  1. ;new code
  1. N SCOK,STATUS,EFFDT,SCNODE
  1. S:'$D(SCDT) SCDT=DT
  1. S SCNODE=$G(^SCPT(404.42,+SCPTTM,0))
  1. ;no act=-1,dt before act=0,no inact=1,dt after inact=0,o/w=1
  1. Q $S(('$P(SCNODE,U,2)):-1,(SCDT<$P(SCNODE,U,2)):0,('$P(SCNODE,U,9)):1,(SCDT>$P(SCNODE,U,9)):0,1:1)
  1. ;
  1. ACTTP(SCTP,SCDT) ;is the team position currently active?
  1. ; Used by computed field #300 (CURRENTLY ACTIVE?) OF file #404.57
  1. ; Input:
  1. ; SCTP - Pointer to Team Position file #404.57
  1. ; SCDT - Date to check for, Default=DT
  1. ; Returns
  1. ; status^status change date
  1. ; status:
  1. ; 1 if after effective date and before inactive date
  1. ; 0 if not yet active or inactivated
  1. ; -1 if error
  1. ;
  1. ;new code
  1. N SCX,STATUS,EFFDT
  1. S:'$D(SCDT) SCDT=DT
  1. S SCX=$$DATES^SCAPMCU1(404.59,SCTP,SCDT)
  1. S STATUS=$P(SCX,U,1)
  1. S EFFDT=$S(STATUS=0:$P(SCX,U,3),(STATUS=1):$P(SCX,U,2),1:"")
  1. QTACTTP Q STATUS_U_EFFDT
  1. ;
  1. ITSCF(CRITERIA,REPORT,X) ;
  1. ;Input transform for 404.93
  1. ;CRITERIA - value of the .01 in 404.93 for entry DA
  1. ;REPORT - value of the .02 in 404.93 for entry DA
  1. ;X - value entered by user
  1. ;X is killed if duplicate
  1. ;
  1. Q:'$G(DA)!'$D(X)
  1. S:'$D(CRITERIA) CRITERIA=$P($G(^SD(404.93,DA,0)),U)
  1. S:'$D(REPORT)#2 REPORT=$P($G(^SD(404.93,DA,0)),U,2)
  1. I $D(^SD(404.93,"APRIM",CRITERIA,REPORT)) D
  1. .D:'$G(DGQUIET) EN^DDIOL("Duplicate Criteria Not Allowed for Same Report","","?5")
  1. .K X
  1. Q
  1. ;
  1. AKEY(REPORT,SORT,X) ;
  1. ;Input transform for 404.92
  1. ;REPORT - value of the .01 in 404.92 for entry DA
  1. ;SORT - value of the .02 in 404.92 for entry DA
  1. ;X - value entered by user
  1. ;X is killed if duplicate
  1. ;
  1. Q:'$G(DA)!'$D(X)
  1. S:'$D(REPORT) REPORT=$P($G(^SD(404.92,DA,0)),U)
  1. S:'$D(SORT)#2 SORT=$P($G(^SD(404.92,DA,0)),U,2)
  1. I $D(^SD(404.92,"AKEY",REPORT,SORT)) D
  1. .D:'$G(DGQUIET) EN^DDIOL("Duplicate SORT BY TEXT Not Allowed for Same Report","","?5")
  1. .K X
  1. Q
  1. ;
  1. IPTF(POSITION,TEAM,X) ;input transform for 404.57
  1. ;kills x if duplicate
  1. Q:'$G(DIUTIL)="VERIFY FIELDS"
  1. Q:'$G(DA)!'$D(X)
  1. S:'$D(POSITION) POSITION=$P($G(^SCTM(404.57,DA,0)),U,1)
  1. S:'$D(TEAM)#2 TEAM=$P($G(^SCTM(404.57,DA,0)),U,2)
  1. ;S:'$G(TEAM) TEAM=$O(^SCTM(404.51,"B",TEAM,0))
  1. IF $D(^SCTM(404.57,"APRIMARY",POSITION,TEAM)) D
  1. .D:'$G(DGQUIET) EN^DDIOL("Duplicate Team Positions Not Allowed","","?5")
  1. .K X
  1. Q
  1. OKACTTP(SCNODE,ACTDT) ;input transform for position assigned date for 404.43
  1. ;
  1. N OK
  1. S OK=1
  1. ;must have input defined
  1. IF '$D(SCNODE)#2!('$G(ACTDT)) S OK=0_U_"Bad input data" G QTOKAC
  1. ;if inactivation exists must be after activation
  1. S:$P(SCNODE,U,4)&($P(SCNODE,U,4)<ACTDT) OK=0_U_"Inactivation date is after this date"
  1. ;position must be active during assignment activation
  1. S:'$$ACTTP(+$P(SCNODE,U,2),ACTDT) OK=0_U_"Position Not active on this date"
  1. S:1>$$ACTPTTM(+$P(SCNODE,U,1),ACTDT) OK=0_U_"No active Patient Team Assignment on this date"
  1. QTOKAC Q OK
  1. OKINTP(SCNODE,INACTDT) ;input transform for inactivation date for 404.43
  1. ;
  1. N OK
  1. S OK=1
  1. ;must have input defined
  1. IF '$D(SCNODE)#2!('$G(INACTDT)) S OK=0 G QTOKIN
  1. ;must have activation date
  1. S:'$P(SCNODE,U,3) OK=0_U_"No activation date in Pt Team Assignment"
  1. ;activation date can't be after inactivation
  1. S:$P(SCNODE,U,3)>INACTDT OK=0_U_"Activation date is after this date"
  1. ;inactivation must be during time when position is active
  1. S:'$$ACTTP(+$P(SCNODE,U,2),INACTDT) OK=0_U_"Inactivation date must be when position is active"
  1. QTOKIN Q OK
  1. ;
  1. OKTP(DA,SCX) ;used by team position field of 404.43
  1. N OK,SCTM,SCPTTMA,SCNODE
  1. S SCNODE=$G(^SCPT(404.43,DA,0))
  1. S OK=1
  1. ;must have input defined
  1. IF '$D(SCNODE)#2!('$G(SCX)) S OK=0 G QTOKTP
  1. S SCTM=$P($G(^SCTM(404.57,SCX,0)),U,2)
  1. S SCPTTMA=$P(SCNODE,U,1)
  1. S:$P($G(^SCPT(404.42,SCPTTMA,0)),U,3)'=SCTM OK=0_U_"Team Position Must be from Team in Pt Team Assignment"
  1. QTOKTP Q OK
  1. ;
  1. OKROLE(DA,SCX) ;used by role .05 field of 404.43
  1. N OK,SCNODE,SCPTTMA,SCPC
  1. S SCNODE=$G(^SCPT(404.43,DA,0))
  1. S OK=1
  1. ;must have input defined
  1. IF '$D(SCNODE)#2!('$D(SCX)) S OK=0_U_"Undefined Patient Team Data" G QTOKTP
  1. S SCPTTMA=$P(SCNODE,U,1)
  1. S:$P($G(^SCPT(404.42,SCPTTMA,0)),U,8)=1 SCPC=1
  1. ;if not a pc team & role is a pc role - not ok
  1. S:('$G(SCPC))&$G(SCX) OK=0_U_"PC Roles only allowed if Pt Team Assignment is for Primary Care"
  1. QTOKRL Q OK
  1. ;
  1. USEUSR() ;should user class functionality be employed?
  1. ; Returned [1=Use USR Class,0=Don't)
  1. Q +$G(^SD(404.91,1,"PCMM"))
  1. ;
  1. ACCLIN(SC44,DATE) ;is clinic active on this date?
  1. ; Return: 1=Yes,0=N0
  1. N SCX
  1. S SCX=+$G(^SC(+$G(SC44),"I"))
  1. Q $S('SCX:1,(SCX>DATE):1,1:0)