SCMCLK ;bp/cmf - Preceptor History Functions ; Sep 1999
;;5.3;Scheduling;**177,204**;AUG 13, 1993
;
; - $$OKPREC functions
; - input variables (required)
; scien := pointer to 404.57 (precepted ien)
; scpien := pointer to 404.57 (preceptor ien)
; sclnkdt := date to test
; - output
; $p1 := 1=assignment ok
; 0=not
; $p2 := if not, reason code
; $p3 := if not, reason
;
OKPREC(SCIEN,SCPIEN,SCLNKDT) ;
;
S SCIEN=+$G(SCIEN,0)
S SCPIEN=+$G(SCPIEN,0)
S SCLNKDT=+$G(SCLNKDT,0)
I (SCIEN<1)!(SCPIEN<1)!(SCLNKDT<1) Q $$S(8)
;
I SCIEN=SCPIEN Q $$S(1)
;
N SCX,SCY,SCPAH,SCPAHA
I '$D(^SCTM(404.57,SCIEN,0)) Q $$S(8)
S SCX=$G(^SCTM(404.57,SCIEN,0))
I '$D(^SCTM(404.57,SCPIEN,0)) Q $$S(8)
S SCY=^SCTM(404.57,SCPIEN,0)
I $P(SCX,U,2)'=$P(SCY,U,2) Q $$S(2)
;
D DTARY(0)
S SCPAH=$$VALHIST^SCAPMCU5(404.53,SCPIEN,"SCPAHA")
I $$ACTHIST^SCAPMCU5("SCPAHA","SCLNKDT") Q $$S(3)
;I $$ACTHIST^SCAPMCU2(404.53,SCPIEN,"SCLNKDT") Q $$S(3)
;
I '+$P(SCY,U,12) Q $$S(4)
;
I +$P(SCX,U,4),'+$P(SCY,U,4) Q $$S(5)
;
I $$ACTHIST^SCAPMCU2(404.59,SCPIEN,"SCLNKDT")<1 Q $$S(6)
;
I $$CHKPRTP() Q $$S(9)
;
Q 1
;
OKPREC1(SCPIEN,SCLNKDT) ;
; ; prevent preceptor assignment danglers
; ; should also return array of danglers, if any,
; ; for a cleanup function, but not asked for yet
;
;
S SCPIEN=+$G(SCPIEN,0)
S SCLNKDT=+$G(SCLNKDT,0)
I (SCPIEN<1)!(SCLNKDT<1) Q $$S(8)
I '$D(^SCTM(404.53,"AD",SCPIEN)) Q 1
;
N SCX,SCN
D DTARY(1)
K ^TMP("SCPHIS",$J)
S SCX=$$PRECHIS(SCPIEN,"SCLNKDT","^TMP(""SCPHIS"",$J)")
K ^TMP("SCPHIS",$J)
;
Q $S(SCX>0:$$S(7),1:1)
;
OKPREC2(SCIEN,SCLNKDT) ; return preceptor ien^name, if any
; ; used for computed field 306 of file 404.57
;
;
S SCIEN=+$G(SCIEN,0)
S SCLNKDT=+$G(SCLNKDT,0)
I (SCIEN<1)!(SCLNKDT<1) Q $$S(8)
N SCX,SCP2,SCP3,SCPIEN,SCLNKLI,SCLNKER,SCPAH,SCPAHA
D DTARY(0)
S SCPAH=$$VALHIST^SCAPMCU5(404.53,SCIEN,"SCPAHA")
S SCX=$$ACTHIST^SCAPMCU5("SCPAHA","SCLNKDT")
;S SCX=$$ACTHIST^SCAPMCU2(404.53,SCIEN,"SCLNKDT")
I +SCX<1 Q ""
S SCP2=$P(SCX,U,2)
I +SCP2<1 Q ""
S SCP3=$P(SCX,U,3)
I '$D(^SCTM(404.53,SCP3,0)) Q $$S(8)
S SCPIEN=$P(^SCTM(404.53,SCP3,0),U,6)
Q $$GETPRTP^SCAPMCU2(SCPIEN,SCLNKDT)
;
OKPREC3(SCIEN,SCLNKDT) ; return preceptor position ien^name, if any
; ; used for computed field 305 of file 404.57
;
;
S SCIEN=+$G(SCIEN,0)
S SCLNKDT=+$G(SCLNKDT,0)
I (SCIEN<1)!(SCLNKDT<1) Q $$S(8)
N SCX,SCP2,SCP3,SCPIEN,SCLNKER,SCPAH,SCPAHA
D DTARY(0)
S SCPAH=$$VALHIST^SCAPMCU5(404.53,SCIEN,"SCPAHA")
S SCX=$$ACTHIST^SCAPMCU5("SCPAHA","SCLNKDT")
;S SCX=$$ACTHIST^SCAPMCU2(404.53,SCIEN,"SCLNKDT")
I +SCX<1 Q ""
S SCP2=$P(SCX,U,2)
I +SCP2<1 Q ""
S SCP3=$P(SCX,U,3)
I '$D(^SCTM(404.53,SCP3,0)) Q $$S(8)
S SCPIEN=$P(^SCTM(404.53,SCP3,0),U,6)
Q SCPIEN_U_$$EXT^SCAPMCU2(404.53,SCPIEN)
;
OKPREC4(SCIEN) ; return if precepted position can be un-precepted
; ; if patient assign after 1st preceptment date, NO
; ; used by computed field #400 of file 404.57
S SCIEN=$G(SCIEN,0)
I (SCIEN<1)!('$D(^SCTM(404.57,SCIEN))) Q $$S(8)
I '$D(^SCTM(404.53,"B",SCIEN)) Q 1
;
N SCVALHIS,SCDT,SCX
S SCDT=$P($$VALHIST^SCAPMCU5(404.53,SCIEN,"SCVALHIS"),U,2)
I SCDT=0 Q 1
S SCX=$$PCPOSCNT^SCAPMCU1(SCIEN,SCDT,0,1)
Q $S(SCX>0:$$S(10),1:1)
;
OKPREC5(SCIEN,SCLNKDT) ; if position has a preceptor,
; ; is preceptor link valid?
;
S SCIEN=$G(SCIEN,0)
S SCLNKDT=$G(SCLNKDT,DT)
I (SCIEN<1)!(SCLNKDT<1) Q $$S(8)
N SCPIEN
S SCPIEN=+$$OKPREC3(SCIEN,SCLNKDT)
I SCPIEN<1 Q 1
Q $$OKPREC(SCIEN,SCPIEN,SCLNKDT)
;
PRECHIS(SCPIEN,SCDATES,SCLIST) ;return precepted positions for preceptor
; input
; SCPIEN := preceptor pos ien (404.57) (required)
; SCDATES := standard PCMM date array (required)
; SCDATES(begin) := start date [default = DT]
; SCDATES(end) := end date [default = DT]
; SCDATES(incl) := always set to 0
; SCLIST := output array (required)
;
; output
; @SCLIST@(scn)
; format :=
; pieces 1-13: same as SCLIST(scn,) node of $$prtp^scapmc8
; pieces 14-16: same as SCLIST(scn,'PR',) node of $$prtp^scapmc8
; @SCLIST@('SCPR',precepted team posn ien (404.57) +
; ,preceptor start date +
; ,preceptor asgn ien, +
; ,precepted posn asgn ien,scn)
;
S SCPIEN=+$G(SCPIEN,0)
S SCDATES=$G(SCDATES)
S SCLIST=$G(SCLIST)
I (SCPIEN<1)!(SCDATES']"")!(SCLIST']"") Q $$S(8)
;
N SCN,SCPVAL,SCPN,SCIEN,SCX,SCXP,SCXPR,SCXARY,SCXDT
N SCPTP,SCPTPN,SCBEGIN,SCEND,SCESEQ,SCLSEQ
N SCP1P11,SCP12,SCP13,SCP14,SCP15,SCP16,SCR
;
S (@SCDATES@("BEGIN"),SCBEGIN)=$G(@SCDATES@("BEGIN"),DT)
S (@SCDATES@("END"),SCEND)=$G(@SCDATES@("END"),DT)
S @SCDATES@("INCL")=0
;
I '$D(^SCTM(404.53,"D",SCPIEN)) Q 0
I '$D(^SCTM(404.53,"AD",SCPIEN)) Q 0
S SCPN=0 ; incrementor
S @SCLIST@(0)=0
S SCIEN=0
F S SCIEN=$O(^SCTM(404.53,"AD",SCPIEN,SCIEN)) Q:'SCIEN D
. ;K SCXPR
. ;S SCX=$$ACTHIST^SCAPMCU2(404.53,SCIEN,.SCDATES,"SCXER","SCXPR")
. ;Q:+SCX<1
. K SCPVAL(SCIEN)
. S SCX=$$VALHIST^SCAPMCU5(404.53,SCIEN,"SCPVAL("_SCIEN_")")
. Q:'$D(SCPVAL(SCIEN))
. S SCX=$$ACTHIST^SCAPMCU5("SCPVAL("_SCIEN_")",.SCDATES)
. Q:+SCX<1
. ;
. S SCX=0
. F S SCX=$O(^SCTM(404.53,"AD",SCPIEN,SCIEN,1,SCX)) Q:'SCX D
. . Q:'$D(SCPVAL(SCIEN,"I",SCX))
. . S SCXARY=$O(SCPVAL(SCIEN,"I",SCX,0))
. . S SCP14=$O(SCPVAL(SCIEN,SCXARY,0)) ;precept start dt
. . S SCP16=$O(SCPVAL(SCIEN,SCXARY,SCP14,0)) ;precept start ien
. . S SCP15=$P(SCPVAL(SCIEN,SCXARY,SCP14,SCP16),U)
. . S SCP15=$S(+SCP15>1:SCP15,1:9999999) ;precept end dt
. . Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,0,SCP14,SCP15)
. . K SCPTP
. . K SCXDT
. . S SCXDT("BEGIN")=SCP14
. . S SCXDT("END")=SCP15
. . S SCXDT("INCL")=0
. . S SCXP=$$PRTP^SCAPMC8(SCIEN,"SCXDT","SCPTP","SCPTPE")
. . Q:+$G(SCPTP(0))<1
. . F SCXP=1:1:SCPTP(0) D
. . . S SCPN=SCPN+1
. . . S SCP1P11=$P(SCPTP(SCXP),U,1,11)
. . . S SCP12=$P(SCPTP(SCXP),U,12)
. . . S SCP13=$P(SCPTP(SCXP),U,13)
. . . S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14_U_SCP15_U_SCP16
. . . S @SCLIST@(0)=SCPN
. . . S @SCLIST@(SCPN)=SCR
. . . S @SCLIST@("SCPR",SCIEN,SCP14,SCP16,$P(SCR,U,11),SCPN)=""
. . . Q
. . Q
. K SCPVAL(SCIEN)
. Q
;
PRECQ Q @SCLIST@(0)>0
;
DTARY(SCX) ;
S SCLNKDT("BEGIN")=SCLNKDT
S SCLNKDT("END")=$S(SCX=1:9999999,1:SCLNKDT)
S SCLNKDT("INCL")=0
;I $G(SCLIST)]"" S SCLNKDT("END")=$G(SCLNKDT0,9999999)
Q
;
CHKPRTP() ;
Q $$GETPRTP^SCAPMCU2(SCIEN,SCLNKDT)=$$GETPRTP^SCAPMCU2(SCPIEN,SCLNKDT)
;
S(SCX) Q 0_U_SCX_U_$P($T(T+SCX),";;",2)_"."
;
T ;;
1 ;;Position can't precept itself;;
2 ;;Preceptor and precepted must be on same team;;
3 ;;Preceptor can't have a preceptor on assignment date;;
4 ;;Preceptor must be able to act as a preceptor;;
5 ;;Preceptor must be PC if precepted is PC;;
6 ;;Preceptor must be active on assignment date;;
7 ;;Active or future precepted position(s);;
8 ;;Invalid Parameter
9 ;;Preceptor/Precepted Staff can't be the same;;
10 ;;Position has patient assignments after precepted date;;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCLK 7451 printed Sep 23, 2025@20:17:07 Page 2
SCMCLK ;bp/cmf - Preceptor History Functions ; Sep 1999
+1 ;;5.3;Scheduling;**177,204**;AUG 13, 1993
+2 ;
+3 ; - $$OKPREC functions
+4 ; - input variables (required)
+5 ; scien := pointer to 404.57 (precepted ien)
+6 ; scpien := pointer to 404.57 (preceptor ien)
+7 ; sclnkdt := date to test
+8 ; - output
+9 ; $p1 := 1=assignment ok
+10 ; 0=not
+11 ; $p2 := if not, reason code
+12 ; $p3 := if not, reason
+13 ;
OKPREC(SCIEN,SCPIEN,SCLNKDT) ;
+1 ;
+2 SET SCIEN=+$GET(SCIEN,0)
+3 SET SCPIEN=+$GET(SCPIEN,0)
+4 SET SCLNKDT=+$GET(SCLNKDT,0)
+5 IF (SCIEN<1)!(SCPIEN<1)!(SCLNKDT<1)
QUIT $$S(8)
+6 ;
+7 IF SCIEN=SCPIEN
QUIT $$S(1)
+8 ;
+9 NEW SCX,SCY,SCPAH,SCPAHA
+10 IF '$DATA(^SCTM(404.57,SCIEN,0))
QUIT $$S(8)
+11 SET SCX=$GET(^SCTM(404.57,SCIEN,0))
+12 IF '$DATA(^SCTM(404.57,SCPIEN,0))
QUIT $$S(8)
+13 SET SCY=^SCTM(404.57,SCPIEN,0)
+14 IF $PIECE(SCX,U,2)'=$PIECE(SCY,U,2)
QUIT $$S(2)
+15 ;
+16 DO DTARY(0)
+17 SET SCPAH=$$VALHIST^SCAPMCU5(404.53,SCPIEN,"SCPAHA")
+18 IF $$ACTHIST^SCAPMCU5("SCPAHA","SCLNKDT")
QUIT $$S(3)
+19 ;I $$ACTHIST^SCAPMCU2(404.53,SCPIEN,"SCLNKDT") Q $$S(3)
+20 ;
+21 IF '+$PIECE(SCY,U,12)
QUIT $$S(4)
+22 ;
+23 IF +$PIECE(SCX,U,4)
IF '+$PIECE(SCY,U,4)
QUIT $$S(5)
+24 ;
+25 IF $$ACTHIST^SCAPMCU2(404.59,SCPIEN,"SCLNKDT")<1
QUIT $$S(6)
+26 ;
+27 IF $$CHKPRTP()
QUIT $$S(9)
+28 ;
+29 QUIT 1
+30 ;
OKPREC1(SCPIEN,SCLNKDT) ;
+1 ; ; prevent preceptor assignment danglers
+2 ; ; should also return array of danglers, if any,
+3 ; ; for a cleanup function, but not asked for yet
+4 ;
+5 ;
+6 SET SCPIEN=+$GET(SCPIEN,0)
+7 SET SCLNKDT=+$GET(SCLNKDT,0)
+8 IF (SCPIEN<1)!(SCLNKDT<1)
QUIT $$S(8)
+9 IF '$DATA(^SCTM(404.53,"AD",SCPIEN))
QUIT 1
+10 ;
+11 NEW SCX,SCN
+12 DO DTARY(1)
+13 KILL ^TMP("SCPHIS",$JOB)
+14 SET SCX=$$PRECHIS(SCPIEN,"SCLNKDT","^TMP(""SCPHIS"",$J)")
+15 KILL ^TMP("SCPHIS",$JOB)
+16 ;
+17 QUIT $SELECT(SCX>0:$$S(7),1:1)
+18 ;
OKPREC2(SCIEN,SCLNKDT) ; return preceptor ien^name, if any
+1 ; ; used for computed field 306 of file 404.57
+2 ;
+3 ;
+4 SET SCIEN=+$GET(SCIEN,0)
+5 SET SCLNKDT=+$GET(SCLNKDT,0)
+6 IF (SCIEN<1)!(SCLNKDT<1)
QUIT $$S(8)
+7 NEW SCX,SCP2,SCP3,SCPIEN,SCLNKLI,SCLNKER,SCPAH,SCPAHA
+8 DO DTARY(0)
+9 SET SCPAH=$$VALHIST^SCAPMCU5(404.53,SCIEN,"SCPAHA")
+10 SET SCX=$$ACTHIST^SCAPMCU5("SCPAHA","SCLNKDT")
+11 ;S SCX=$$ACTHIST^SCAPMCU2(404.53,SCIEN,"SCLNKDT")
+12 IF +SCX<1
QUIT ""
+13 SET SCP2=$PIECE(SCX,U,2)
+14 IF +SCP2<1
QUIT ""
+15 SET SCP3=$PIECE(SCX,U,3)
+16 IF '$DATA(^SCTM(404.53,SCP3,0))
QUIT $$S(8)
+17 SET SCPIEN=$PIECE(^SCTM(404.53,SCP3,0),U,6)
+18 QUIT $$GETPRTP^SCAPMCU2(SCPIEN,SCLNKDT)
+19 ;
OKPREC3(SCIEN,SCLNKDT) ; return preceptor position ien^name, if any
+1 ; ; used for computed field 305 of file 404.57
+2 ;
+3 ;
+4 SET SCIEN=+$GET(SCIEN,0)
+5 SET SCLNKDT=+$GET(SCLNKDT,0)
+6 IF (SCIEN<1)!(SCLNKDT<1)
QUIT $$S(8)
+7 NEW SCX,SCP2,SCP3,SCPIEN,SCLNKER,SCPAH,SCPAHA
+8 DO DTARY(0)
+9 SET SCPAH=$$VALHIST^SCAPMCU5(404.53,SCIEN,"SCPAHA")
+10 SET SCX=$$ACTHIST^SCAPMCU5("SCPAHA","SCLNKDT")
+11 ;S SCX=$$ACTHIST^SCAPMCU2(404.53,SCIEN,"SCLNKDT")
+12 IF +SCX<1
QUIT ""
+13 SET SCP2=$PIECE(SCX,U,2)
+14 IF +SCP2<1
QUIT ""
+15 SET SCP3=$PIECE(SCX,U,3)
+16 IF '$DATA(^SCTM(404.53,SCP3,0))
QUIT $$S(8)
+17 SET SCPIEN=$PIECE(^SCTM(404.53,SCP3,0),U,6)
+18 QUIT SCPIEN_U_$$EXT^SCAPMCU2(404.53,SCPIEN)
+19 ;
OKPREC4(SCIEN) ; return if precepted position can be un-precepted
+1 ; ; if patient assign after 1st preceptment date, NO
+2 ; ; used by computed field #400 of file 404.57
+3 SET SCIEN=$GET(SCIEN,0)
+4 IF (SCIEN<1)!('$DATA(^SCTM(404.57,SCIEN)))
QUIT $$S(8)
+5 IF '$DATA(^SCTM(404.53,"B",SCIEN))
QUIT 1
+6 ;
+7 NEW SCVALHIS,SCDT,SCX
+8 SET SCDT=$PIECE($$VALHIST^SCAPMCU5(404.53,SCIEN,"SCVALHIS"),U,2)
+9 IF SCDT=0
QUIT 1
+10 SET SCX=$$PCPOSCNT^SCAPMCU1(SCIEN,SCDT,0,1)
+11 QUIT $SELECT(SCX>0:$$S(10),1:1)
+12 ;
OKPREC5(SCIEN,SCLNKDT) ; if position has a preceptor,
+1 ; ; is preceptor link valid?
+2 ;
+3 SET SCIEN=$GET(SCIEN,0)
+4 SET SCLNKDT=$GET(SCLNKDT,DT)
+5 IF (SCIEN<1)!(SCLNKDT<1)
QUIT $$S(8)
+6 NEW SCPIEN
+7 SET SCPIEN=+$$OKPREC3(SCIEN,SCLNKDT)
+8 IF SCPIEN<1
QUIT 1
+9 QUIT $$OKPREC(SCIEN,SCPIEN,SCLNKDT)
+10 ;
PRECHIS(SCPIEN,SCDATES,SCLIST) ;return precepted positions for preceptor
+1 ; input
+2 ; SCPIEN := preceptor pos ien (404.57) (required)
+3 ; SCDATES := standard PCMM date array (required)
+4 ; SCDATES(begin) := start date [default = DT]
+5 ; SCDATES(end) := end date [default = DT]
+6 ; SCDATES(incl) := always set to 0
+7 ; SCLIST := output array (required)
+8 ;
+9 ; output
+10 ; @SCLIST@(scn)
+11 ; format :=
+12 ; pieces 1-13: same as SCLIST(scn,) node of $$prtp^scapmc8
+13 ; pieces 14-16: same as SCLIST(scn,'PR',) node of $$prtp^scapmc8
+14 ; @SCLIST@('SCPR',precepted team posn ien (404.57) +
+15 ; ,preceptor start date +
+16 ; ,preceptor asgn ien, +
+17 ; ,precepted posn asgn ien,scn)
+18 ;
+19 SET SCPIEN=+$GET(SCPIEN,0)
+20 SET SCDATES=$GET(SCDATES)
+21 SET SCLIST=$GET(SCLIST)
+22 IF (SCPIEN<1)!(SCDATES']"")!(SCLIST']"")
QUIT $$S(8)
+23 ;
+24 NEW SCN,SCPVAL,SCPN,SCIEN,SCX,SCXP,SCXPR,SCXARY,SCXDT
+25 NEW SCPTP,SCPTPN,SCBEGIN,SCEND,SCESEQ,SCLSEQ
+26 NEW SCP1P11,SCP12,SCP13,SCP14,SCP15,SCP16,SCR
+27 ;
+28 SET (@SCDATES@("BEGIN"),SCBEGIN)=$GET(@SCDATES@("BEGIN"),DT)
+29 SET (@SCDATES@("END"),SCEND)=$GET(@SCDATES@("END"),DT)
+30 SET @SCDATES@("INCL")=0
+31 ;
+32 IF '$DATA(^SCTM(404.53,"D",SCPIEN))
QUIT 0
+33 IF '$DATA(^SCTM(404.53,"AD",SCPIEN))
QUIT 0
+34 ; incrementor
SET SCPN=0
+35 SET @SCLIST@(0)=0
+36 SET SCIEN=0
+37 FOR
SET SCIEN=$ORDER(^SCTM(404.53,"AD",SCPIEN,SCIEN))
if 'SCIEN
QUIT
Begin DoDot:1
+38 ;K SCXPR
+39 ;S SCX=$$ACTHIST^SCAPMCU2(404.53,SCIEN,.SCDATES,"SCXER","SCXPR")
+40 ;Q:+SCX<1
+41 KILL SCPVAL(SCIEN)
+42 SET SCX=$$VALHIST^SCAPMCU5(404.53,SCIEN,"SCPVAL("_SCIEN_")")
+43 if '$DATA(SCPVAL(SCIEN))
QUIT
+44 SET SCX=$$ACTHIST^SCAPMCU5("SCPVAL("_SCIEN_")",.SCDATES)
+45 if +SCX<1
QUIT
+46 ;
+47 SET SCX=0
+48 FOR
SET SCX=$ORDER(^SCTM(404.53,"AD",SCPIEN,SCIEN,1,SCX))
if 'SCX
QUIT
Begin DoDot:2
+49 if '$DATA(SCPVAL(SCIEN,"I",SCX))
QUIT
+50 SET SCXARY=$ORDER(SCPVAL(SCIEN,"I",SCX,0))
+51 ;precept start dt
SET SCP14=$ORDER(SCPVAL(SCIEN,SCXARY,0))
+52 ;precept start ien
SET SCP16=$ORDER(SCPVAL(SCIEN,SCXARY,SCP14,0))
+53 SET SCP15=$PIECE(SCPVAL(SCIEN,SCXARY,SCP14,SCP16),U)
+54 ;precept end dt
SET SCP15=$SELECT(+SCP15>1:SCP15,1:9999999)
+55 if '$$DTCHK^SCAPU1(SCBEGIN,SCEND,0,SCP14,SCP15)
QUIT
+56 KILL SCPTP
+57 KILL SCXDT
+58 SET SCXDT("BEGIN")=SCP14
+59 SET SCXDT("END")=SCP15
+60 SET SCXDT("INCL")=0
+61 SET SCXP=$$PRTP^SCAPMC8(SCIEN,"SCXDT","SCPTP","SCPTPE")
+62 if +$GET(SCPTP(0))<1
QUIT
+63 FOR SCXP=1:1:SCPTP(0)
Begin DoDot:3
+64 SET SCPN=SCPN+1
+65 SET SCP1P11=$PIECE(SCPTP(SCXP),U,1,11)
+66 SET SCP12=$PIECE(SCPTP(SCXP),U,12)
+67 SET SCP13=$PIECE(SCPTP(SCXP),U,13)
+68 SET SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14_U_SCP15_U_SCP16
+69 SET @SCLIST@(0)=SCPN
+70 SET @SCLIST@(SCPN)=SCR
+71 SET @SCLIST@("SCPR",SCIEN,SCP14,SCP16,$PIECE(SCR,U,11),SCPN)=""
+72 QUIT
End DoDot:3
+73 QUIT
End DoDot:2
+74 KILL SCPVAL(SCIEN)
+75 QUIT
End DoDot:1
+76 ;
PRECQ QUIT @SCLIST@(0)>0
+1 ;
DTARY(SCX) ;
+1 SET SCLNKDT("BEGIN")=SCLNKDT
+2 SET SCLNKDT("END")=$SELECT(SCX=1:9999999,1:SCLNKDT)
+3 SET SCLNKDT("INCL")=0
+4 ;I $G(SCLIST)]"" S SCLNKDT("END")=$G(SCLNKDT0,9999999)
+5 QUIT
+6 ;
CHKPRTP() ;
+1 QUIT $$GETPRTP^SCAPMCU2(SCIEN,SCLNKDT)=$$GETPRTP^SCAPMCU2(SCPIEN,SCLNKDT)
+2 ;
S(SCX) QUIT 0_U_SCX_U_$PIECE($TEXT(T+SCX),";;",2)_"."
+1 ;
T ;;
1 ;;Position can't precept itself;;
2 ;;Preceptor and precepted must be on same team;;
3 ;;Preceptor can't have a preceptor on assignment date;;
4 ;;Preceptor must be able to act as a preceptor;;
5 ;;Preceptor must be PC if precepted is PC;;
6 ;;Preceptor must be active on assignment date;;
7 ;;Active or future precepted position(s);;
8 ;;Invalid Parameter
9 ;;Preceptor/Precepted Staff can't be the same;;
10 ;;Position has patient assignments after precepted date;;
+1 ;
