SCAPMCU1 ;ALB/REW - TEAM API UTILITIES ; 7/12/99 9:33am ;07/06/2017
;;5.3;Scheduling;**41,45,48,177,666**;AUG 13, 1993;Build 4
;;1.0
INIT(SCOK) ; setup date array & error arrays if none passed in
; VARIABLES SET:
; SCOK - SET TO 0 IF ERROR
;
; Makes sure the following are defined:
; scbegin,scend,scincl,@scdates('begin'),@scdates@('end'),@scdates@('incl') - defaults are today & inclusive
;
; Note: you should NEW the above just before making this call
; ---
N SCNOW ;666
S (SCN,SCESEQ,SCLSEQ)=0
IF '$L($G(SCERR)) K ^TMP("SCERR",$J) S SCERR="^TMP(""SCERR"",$J)"
IF '$L($G(SCLIST)) S SCLIST="^TMP(""SC TMP LIST"",$J)" K ^TMP("SC TMP LIST",$J)
IF (SCERR="SCERR")!(SCERR="SCLIST")!((SCERR'?1A1.7AN)&(SCERR'?1"^"1A.20E)) D S SCOK=0
. S SCPARM("ERROR ARRAY")=$G(SCERR,"Undefined")
. D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
IF SCLIST="SCERR"!(SCLIST="SCLIST")!((SCLIST'?1A1.7AN.1"(".60E)&(SCLIST'?1"^"1A1.7AN.1"(".60E)) S SCOK=0 D S SCOK=0
. S SCPARM("OUTPUT ARRAY")=$G(SCLIST,"Undefined")
. D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
S:'$D(SCDATES)!($G(SCDATES)="") SCDATES="SCDTS"
S SCNOW=$$NOW^XLFDT ;666
S SCBEGIN=$G(@SCDATES@("BEGIN"),SCNOW),SCBEGIN=$S(SCBEGIN:SCBEGIN,1:SCNOW) ;666
S SCEND=$G(@SCDATES@("END"),SCNOW),SCEND=$S(SCEND:SCEND,1:SCNOW) ;666
S SCINCL=$G(@SCDATES@("INCL"),1)
S (SCN,SCESEQ,SCLSEQ)=0
S:'$D(@SCDATES@("BEGIN")) @SCDATES@("BEGIN")=SCBEGIN
S:'$D(@SCDATES@("END")) @SCDATES@("END")=SCEND
S:'$D(@SCDATES@("INCL")) @SCDATES@("INCL")=SCINCL
Q
;
; bp/cmf 177 - added SCFUTURE input param, used at PCPOSCNT+17
;;bp/cmf 177; orig entry call; PCPOSCNT(SCTP,SCDATE,SCPCONLY);this is a more efficient count of PC patients assigned to position
PCPOSCNT(SCTP,SCDATE,SCPCONLY,SCFUTURE) ;this is a more efficient count of PC patients assigned to position
; Input: SCTP - ien to 404.57
; SCDATE - date of concern, default=DT
; SCPCONLY - 1= must be pc, 0=all assignments 1=DEFAULT
; SCFUTURE - 1= include future, 0=current 0=DEFAULT ;;bp/cmf 177
;returns count of patient assignments or -1 if error
N SCPTPA,SCCNT,SCHSTIEN,SCNODE
Q:'$G(SCTP) -1
S SCDATE=$G(SCDATE,DT)
S:'$L($G(SCPCONLY)) SCPCONLY=1
S:'$L($G(SCFUTURE)) SCFUTURE=0 ;;bp/cmf 177 add
S (SCPTPA,SCCNT)=0
F S SCPTPA=$O(^SCPT(404.43,"APTPA",SCTP,SCPTPA)) Q:'SCPTPA D
.S SCHSTIEN=0
.F S SCHSTIEN=$O(^SCPT(404.43,"APTPA",SCTP,SCPTPA,SCHSTIEN)) Q:'SCHSTIEN D
..S SCNODE=$G(^SCPT(404.43,SCHSTIEN,0))
..Q:$P(SCNODE,U,4)&($P(SCNODE,U,4)<SCDATE)
..;;bp/cmf 177;orig code;;Q:$P(SCNODE,U,3)>SCDATE
..Q:('SCFUTURE)&($P(SCNODE,U,3)>SCDATE) ;;bp/cmf 177 mod-use scfuture
..Q:SCPCONLY&('$P(SCNODE,U,5)) ;pc role is not 1 or 2
..S SCCNT=SCCNT+1
Q SCCNT
;
TEAMCNT(SCTM,DATE) ;this is a more efficient version of the count
N DFN,SCCNT,SCNODE,HISTIEN
Q:'$G(SCTM) 0
S DATE=$G(DATE,DT)
S (DFN,SCCNT)=0
F S DFN=$O(^SCPT(404.42,"ATMPT",SCTM,DFN)) Q:'DFN D
.S HISTIEN=0
.F S HISTIEN=$O(^SCPT(404.42,"ATMPT",SCTM,DFN,HISTIEN)) Q:'HISTIEN D
..S SCNODE=$G(^SCPT(404.42,HISTIEN,0))
..Q:$P(SCNODE,U,9)&($P(SCNODE,U,9)<DATE)
..Q:$P(SCNODE,U,2)>DATE
..S SCCNT=SCCNT+1
Q SCCNT
;
TEAMCNT2(SCTM,DATE) ;this is the count of patients assigned to the team on a date
; Input: SCTM - ien to 404.51
; DATE - date of concern, default=DT
N SCX,SCDATES,SCTEAMS,SCERR,X
S SCDATES("BEGIN")=$G(DATE,DT)
S SCDATES("END")=SCDATES("BEGIN")
S SCX=$$PTTM^SCAPMC(SCTM,"SCDATES","^TMP(""SCTEAMS"",$J,""CNT"")","SCERRX")
IF 'SCX S X=-SCX
ELSE D
.S DFN=0
.F X=0:1 S DFN=$O(^TMP("SCTEAMS",$J,"CNT","SCPTA",DFN)) Q:'DFN
K ^TMP("SCTEAMS",$J,"CNT")
Q X
ACTHISTB(FILE,IEN) ;boolean active function
;MOVED TO SCAPMCU2
Q $$ACTHISTB^SCAPMCU2(.FILE,.IEN)
ACTHIST(FILE,IEN,SCDATES,SCERR) ;is entry active for a time period?
;MOVED TO SCAPMCU2
Q $$ACTHIST^SCAPMCU2(.FILE,.IEN,.SCDATES,.SCERR)
;
LASTDATE(FILE,IEN) ;gets last date for team or position from 404.52,404.58,404.59 - uses DATES function below
; Input Parameters:
; File = either 404.52 or 404.58 or 404.59
; IEN = pointer to team(404.51) or team position(404.57)
; Returned:
; -1 if error,o/w latest date defined 0=no historical dates
N SCX
S SCX=$$DATES(.FILE,.IEN,3990101) ; gets dates as of 1/1/2999
Q $S($P(SCX,U,1)<0:-1,$P(SCX,U,3):$P(SCX,U,3),1:+$P(SCX,U,2))
;
DATES(FILE,IEN,DATE) ;used to return latest activation & inactivation date
; Input Parameters:
; File = either 404.52, 404.53, 404.58, or 404.59
; IEN = pointer to team(404.51) or team position(404.57)
; DATE = default=DT
; Returned:
; status^actdate^inactdate^scien^first actdate? [1=yes/null=no]
ST N ROOT,EFFDT,STATUS,ACTDT,INACTDT,X,FUTURE,PREVDT,SCTODAY,PREVST,SCSTAT,SCIEN,SCLAST
S:'$G(DATE) DATE=DT
S STATUS=-1,SCTODAY=0
S SCSTAT=1
;bp/cmf - 177 change begin
G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
;orig;G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
;bp/cmf - 177 change begin
S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT"
S EFFDT=-DATE
S X=ROOT_")"
;if there is an active x-ref
IF $D(@X) D
.;if today is an activation date
.IF $D(@X@(EFFDT)) S ACTDT=-EFFDT
.;if today is not an activation date get previous one
.ELSE D
..S ACTDT=-$O(@X@(EFFDT))
.;if no activation in past get one in future
.S:'$G(ACTDT) ACTDT=-$O(@X@(EFFDT),-1),FUTURE=1
.S SCSTAT=0
.S INACTDT=$O(@X@(-(ACTDT-.000001)),-1),INACTDT=$S(INACTDT:-INACTDT,1:INACTDT)
.S STATUS=$$DTCHK^SCAPU1(DATE,DATE,0,ACTDT,INACTDT)
.S SCSTAT=STATUS
.S X=ROOT_","_$S(SCSTAT:-ACTDT,1:-INACTDT)_")"
.S SCIEN=$O(@X@(0))
ELSE D
.S STATUS=0
QTDATES Q STATUS_U_$G(ACTDT)_U_$G(INACTDT)_U_$G(SCIEN)_U_$G(FUTURE)
;
ERR(SEQ,ERNUM,PARMS,OUTPUT,SCER) ;-- process errors
;if no dialog entry 4040000 will be processed
S ERNUM=$G(ERNUM,4040000)
S:'$$GET1^DIQ(.84,$G(ERNUM)_",",.01) ERNUM=4040000
IF SCER]"" D
. S SEQ=$G(SEQ,0)+1
. S SCER(SEQ)=ERNUM
. ;S @SCER@(0)=$G(@SCER@(0))+1 ;bp/djb 7/12/99
. S SCER(0)=$G(SCER(0))+1
. ;D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,.SCER) ;bp/djb 7/12/99
. D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,"SCER")
Q
;
OKTMPOS(TEAM,POSITION,DATE) ;validate legitimate position in a team for a dt
; used in screen for pc practitioner position of patient team assngt
;
; TEAM - ien of team file
; POSITION - ien of team position file
; DATE - date of interest
; return 1 if ok, 0 ow
;
CHK ;
N SCTP,SCOK,SCPOS0
S SCOK=0
S:'$L($G(SCERR)) SCERR="^TMP(""SCERR"",$J)"
IF '$D(^SCTM(404.51,+$G(TEAM),0)) D G QTOKTP
. S SCPARM("TEAM")=$G(TEAM,"Undefined")
. D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
IF '$D(^SCTM(404.57,+$G(POSITION),0)) D G QTOKTP
. S SCPARM("POSITION")=$G(POSITION,"Undefined")
. D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
IF '$G(DATE) D G QTOKTP
. S SCPARM("DATE")=$G(DATE,"Undefined")
. D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
S SCPOS0=$G(^SCTM(404.57,POSITION,0))
;if position not linked to team
G QTOKTP:$P(SCPOS0,U,2)'=TEAM
;if not active position
G QTOKTP:'$$DATES(404.59,POSITION,DATE)
S SCOK=1
QTOKTP Q SCOK
RSNDICS(EVCODE) ; -- called by input transform and screen logic for type of reason
; Input: EVCODE = event code (e.g. ZM1)
; Used to check for fields that point to Scheduling Reason File
; Piece = Piece number of zero node of
Q $P(^SD(403.43,$P(^(0),U,2),0),U,1)=EVCODE
;
OKPREC(TEAM) ; - called by screen logic for preceptor position file (#.1) of team position (#404.57) file
; Input; TEAM = Pointer to team file (#404.51) for team position with preceptor
; requires position being assigned to be a possible preceptor position
; AND that position is from the same team as the supervised position
Q ($P(^SCTM(404.57,Y,0),U,12))&($P(^SCTM(404.57,Y,0),U,2)=TEAM)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMCU1 7951 printed Oct 16, 2024@18:38:55 Page 2
SCAPMCU1 ;ALB/REW - TEAM API UTILITIES ; 7/12/99 9:33am ;07/06/2017
+1 ;;5.3;Scheduling;**41,45,48,177,666**;AUG 13, 1993;Build 4
+2 ;;1.0
INIT(SCOK) ; setup date array & error arrays if none passed in
+1 ; VARIABLES SET:
+2 ; SCOK - SET TO 0 IF ERROR
+3 ;
+4 ; Makes sure the following are defined:
+5 ; scbegin,scend,scincl,@scdates('begin'),@scdates@('end'),@scdates@('incl') - defaults are today & inclusive
+6 ;
+7 ; Note: you should NEW the above just before making this call
+8 ; ---
+9 ;666
NEW SCNOW
+10 SET (SCN,SCESEQ,SCLSEQ)=0
+11 IF '$LENGTH($GET(SCERR))
KILL ^TMP("SCERR",$JOB)
SET SCERR="^TMP(""SCERR"",$J)"
+12 IF '$LENGTH($GET(SCLIST))
SET SCLIST="^TMP(""SC TMP LIST"",$J)"
KILL ^TMP("SC TMP LIST",$JOB)
+13 IF (SCERR="SCERR")!(SCERR="SCLIST")!((SCERR'?1A1.7AN)&(SCERR'?1"^"1A.20E))
Begin DoDot:1
+14 SET SCPARM("ERROR ARRAY")=$GET(SCERR,"Undefined")
+15 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
SET SCOK=0
+16 IF SCLIST="SCERR"!(SCLIST="SCLIST")!((SCLIST'?1A1.7AN.1"(".60E)&(SCLIST'?1"^"1A1.7AN.1"(".60E))
SET SCOK=0
Begin DoDot:1
+17 SET SCPARM("OUTPUT ARRAY")=$GET(SCLIST,"Undefined")
+18 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
SET SCOK=0
+19 if '$DATA(SCDATES)!($GET(SCDATES)="")
SET SCDATES="SCDTS"
+20 ;666
SET SCNOW=$$NOW^XLFDT
+21 ;666
SET SCBEGIN=$GET(@SCDATES@("BEGIN"),SCNOW)
SET SCBEGIN=$SELECT(SCBEGIN:SCBEGIN,1:SCNOW)
+22 ;666
SET SCEND=$GET(@SCDATES@("END"),SCNOW)
SET SCEND=$SELECT(SCEND:SCEND,1:SCNOW)
+23 SET SCINCL=$GET(@SCDATES@("INCL"),1)
+24 SET (SCN,SCESEQ,SCLSEQ)=0
+25 if '$DATA(@SCDATES@("BEGIN"))
SET @SCDATES@("BEGIN")=SCBEGIN
+26 if '$DATA(@SCDATES@("END"))
SET @SCDATES@("END")=SCEND
+27 if '$DATA(@SCDATES@("INCL"))
SET @SCDATES@("INCL")=SCINCL
+28 QUIT
+29 ;
+30 ; bp/cmf 177 - added SCFUTURE input param, used at PCPOSCNT+17
+31 ;;bp/cmf 177; orig entry call; PCPOSCNT(SCTP,SCDATE,SCPCONLY);this is a more efficient count of PC patients assigned to position
PCPOSCNT(SCTP,SCDATE,SCPCONLY,SCFUTURE) ;this is a more efficient count of PC patients assigned to position
+1 ; Input: SCTP - ien to 404.57
+2 ; SCDATE - date of concern, default=DT
+3 ; SCPCONLY - 1= must be pc, 0=all assignments 1=DEFAULT
+4 ; SCFUTURE - 1= include future, 0=current 0=DEFAULT ;;bp/cmf 177
+5 ;returns count of patient assignments or -1 if error
+6 NEW SCPTPA,SCCNT,SCHSTIEN,SCNODE
+7 if '$GET(SCTP)
QUIT -1
+8 SET SCDATE=$GET(SCDATE,DT)
+9 if '$LENGTH($GET(SCPCONLY))
SET SCPCONLY=1
+10 ;;bp/cmf 177 add
if '$LENGTH($GET(SCFUTURE))
SET SCFUTURE=0
+11 SET (SCPTPA,SCCNT)=0
+12 FOR
SET SCPTPA=$ORDER(^SCPT(404.43,"APTPA",SCTP,SCPTPA))
if 'SCPTPA
QUIT
Begin DoDot:1
+13 SET SCHSTIEN=0
+14 FOR
SET SCHSTIEN=$ORDER(^SCPT(404.43,"APTPA",SCTP,SCPTPA,SCHSTIEN))
if 'SCHSTIEN
QUIT
Begin DoDot:2
+15 SET SCNODE=$GET(^SCPT(404.43,SCHSTIEN,0))
+16 if $PIECE(SCNODE,U,4)&($PIECE(SCNODE,U,4)<SCDATE)
QUIT
+17 ;;bp/cmf 177;orig code;;Q:$P(SCNODE,U,3)>SCDATE
+18 ;;bp/cmf 177 mod-use scfuture
if ('SCFUTURE)&($PIECE(SCNODE,U,3)>SCDATE)
QUIT
+19 ;pc role is not 1 or 2
if SCPCONLY&('$PIECE(SCNODE,U,5))
QUIT
+20 SET SCCNT=SCCNT+1
End DoDot:2
End DoDot:1
+21 QUIT SCCNT
+22 ;
TEAMCNT(SCTM,DATE) ;this is a more efficient version of the count
+1 NEW DFN,SCCNT,SCNODE,HISTIEN
+2 if '$GET(SCTM)
QUIT 0
+3 SET DATE=$GET(DATE,DT)
+4 SET (DFN,SCCNT)=0
+5 FOR
SET DFN=$ORDER(^SCPT(404.42,"ATMPT",SCTM,DFN))
if 'DFN
QUIT
Begin DoDot:1
+6 SET HISTIEN=0
+7 FOR
SET HISTIEN=$ORDER(^SCPT(404.42,"ATMPT",SCTM,DFN,HISTIEN))
if 'HISTIEN
QUIT
Begin DoDot:2
+8 SET SCNODE=$GET(^SCPT(404.42,HISTIEN,0))
+9 if $PIECE(SCNODE,U,9)&($PIECE(SCNODE,U,9)<DATE)
QUIT
+10 if $PIECE(SCNODE,U,2)>DATE
QUIT
+11 SET SCCNT=SCCNT+1
End DoDot:2
End DoDot:1
+12 QUIT SCCNT
+13 ;
TEAMCNT2(SCTM,DATE) ;this is the count of patients assigned to the team on a date
+1 ; Input: SCTM - ien to 404.51
+2 ; DATE - date of concern, default=DT
+3 NEW SCX,SCDATES,SCTEAMS,SCERR,X
+4 SET SCDATES("BEGIN")=$GET(DATE,DT)
+5 SET SCDATES("END")=SCDATES("BEGIN")
+6 SET SCX=$$PTTM^SCAPMC(SCTM,"SCDATES","^TMP(""SCTEAMS"",$J,""CNT"")","SCERRX")
+7 IF 'SCX
SET X=-SCX
+8 IF '$TEST
Begin DoDot:1
+9 SET DFN=0
+10 FOR X=0:1
SET DFN=$ORDER(^TMP("SCTEAMS",$JOB,"CNT","SCPTA",DFN))
if 'DFN
QUIT
End DoDot:1
+11 KILL ^TMP("SCTEAMS",$JOB,"CNT")
+12 QUIT X
ACTHISTB(FILE,IEN) ;boolean active function
+1 ;MOVED TO SCAPMCU2
+2 QUIT $$ACTHISTB^SCAPMCU2(.FILE,.IEN)
ACTHIST(FILE,IEN,SCDATES,SCERR) ;is entry active for a time period?
+1 ;MOVED TO SCAPMCU2
+2 QUIT $$ACTHIST^SCAPMCU2(.FILE,.IEN,.SCDATES,.SCERR)
+3 ;
LASTDATE(FILE,IEN) ;gets last date for team or position from 404.52,404.58,404.59 - uses DATES function below
+1 ; Input Parameters:
+2 ; File = either 404.52 or 404.58 or 404.59
+3 ; IEN = pointer to team(404.51) or team position(404.57)
+4 ; Returned:
+5 ; -1 if error,o/w latest date defined 0=no historical dates
+6 NEW SCX
+7 ; gets dates as of 1/1/2999
SET SCX=$$DATES(.FILE,.IEN,3990101)
+8 QUIT $SELECT($PIECE(SCX,U,1)<0:-1,$PIECE(SCX,U,3):$PIECE(SCX,U,3),1:+$PIECE(SCX,U,2))
+9 ;
DATES(FILE,IEN,DATE) ;used to return latest activation & inactivation date
+1 ; Input Parameters:
+2 ; File = either 404.52, 404.53, 404.58, or 404.59
+3 ; IEN = pointer to team(404.51) or team position(404.57)
+4 ; DATE = default=DT
+5 ; Returned:
+6 ; status^actdate^inactdate^scien^first actdate? [1=yes/null=no]
ST NEW ROOT,EFFDT,STATUS,ACTDT,INACTDT,X,FUTURE,PREVDT,SCTODAY,PREVST,SCSTAT,SCIEN,SCLAST
+1 if '$GET(DATE)
SET DATE=DT
+2 SET STATUS=-1
SET SCTODAY=0
+3 SET SCSTAT=1
+4 ;bp/cmf - 177 change begin
+5 if ('$GET(FILE))!("^404.52^404.53^404.58^404.59^"'[$GET(FILE))!('$GET(IEN))
GOTO QTDATES
+6 ;orig;G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
+7 ;bp/cmf - 177 change begin
+8 SET ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT"
+9 SET EFFDT=-DATE
+10 SET X=ROOT_")"
+11 ;if there is an active x-ref
+12 IF $DATA(@X)
Begin DoDot:1
+13 ;if today is an activation date
+14 IF $DATA(@X@(EFFDT))
SET ACTDT=-EFFDT
+15 ;if today is not an activation date get previous one
+16 IF '$TEST
Begin DoDot:2
+17 SET ACTDT=-$ORDER(@X@(EFFDT))
End DoDot:2
+18 ;if no activation in past get one in future
+19 if '$GET(ACTDT)
SET ACTDT=-$ORDER(@X@(EFFDT),-1)
SET FUTURE=1
+20 SET SCSTAT=0
+21 SET INACTDT=$ORDER(@X@(-(ACTDT-.000001)),-1)
SET INACTDT=$SELECT(INACTDT:-INACTDT,1:INACTDT)
+22 SET STATUS=$$DTCHK^SCAPU1(DATE,DATE,0,ACTDT,INACTDT)
+23 SET SCSTAT=STATUS
+24 SET X=ROOT_","_$SELECT(SCSTAT:-ACTDT,1:-INACTDT)_")"
+25 SET SCIEN=$ORDER(@X@(0))
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 SET STATUS=0
End DoDot:1
QTDATES QUIT STATUS_U_$GET(ACTDT)_U_$GET(INACTDT)_U_$GET(SCIEN)_U_$GET(FUTURE)
+1 ;
ERR(SEQ,ERNUM,PARMS,OUTPUT,SCER) ;-- process errors
+1 ;if no dialog entry 4040000 will be processed
+2 SET ERNUM=$GET(ERNUM,4040000)
+3 if '$$GET1^DIQ(.84,$GET(ERNUM)_",",.01)
SET ERNUM=4040000
+4 IF SCER]""
Begin DoDot:1
+5 SET SEQ=$GET(SEQ,0)+1
+6 SET SCER(SEQ)=ERNUM
+7 ;S @SCER@(0)=$G(@SCER@(0))+1 ;bp/djb 7/12/99
+8 SET SCER(0)=$GET(SCER(0))+1
+9 ;D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,.SCER) ;bp/djb 7/12/99
+10 DO BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,"SCER")
End DoDot:1
+11 QUIT
+12 ;
OKTMPOS(TEAM,POSITION,DATE) ;validate legitimate position in a team for a dt
+1 ; used in screen for pc practitioner position of patient team assngt
+2 ;
+3 ; TEAM - ien of team file
+4 ; POSITION - ien of team position file
+5 ; DATE - date of interest
+6 ; return 1 if ok, 0 ow
+7 ;
CHK ;
+1 NEW SCTP,SCOK,SCPOS0
+2 SET SCOK=0
+3 if '$LENGTH($GET(SCERR))
SET SCERR="^TMP(""SCERR"",$J)"
+4 IF '$DATA(^SCTM(404.51,+$GET(TEAM),0))
Begin DoDot:1
+5 SET SCPARM("TEAM")=$GET(TEAM,"Undefined")
+6 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
GOTO QTOKTP
+7 IF '$DATA(^SCTM(404.57,+$GET(POSITION),0))
Begin DoDot:1
+8 SET SCPARM("POSITION")=$GET(POSITION,"Undefined")
+9 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
GOTO QTOKTP
+10 IF '$GET(DATE)
Begin DoDot:1
+11 SET SCPARM("DATE")=$GET(DATE,"Undefined")
+12 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
GOTO QTOKTP
+13 SET SCPOS0=$GET(^SCTM(404.57,POSITION,0))
+14 ;if position not linked to team
+15 if $PIECE(SCPOS0,U,2)'=TEAM
GOTO QTOKTP
+16 ;if not active position
+17 if '$$DATES(404.59,POSITION,DATE)
GOTO QTOKTP
+18 SET SCOK=1
QTOKTP QUIT SCOK
RSNDICS(EVCODE) ; -- called by input transform and screen logic for type of reason
+1 ; Input: EVCODE = event code (e.g. ZM1)
+2 ; Used to check for fields that point to Scheduling Reason File
+3 ; Piece = Piece number of zero node of
+4 QUIT $PIECE(^SD(403.43,$PIECE(^(0),U,2),0),U,1)=EVCODE
+5 ;
OKPREC(TEAM) ; - called by screen logic for preceptor position file (#.1) of team position (#404.57) file
+1 ; Input; TEAM = Pointer to team file (#404.51) for team position with preceptor
+2 ; requires position being assigned to be a possible preceptor position
+3 ; AND that position is from the same team as the supervised position
+4 QUIT ($PIECE(^SCTM(404.57,Y,0),U,12))&($PIECE(^SCTM(404.57,Y,0),U,2)=TEAM)
