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