- 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 Jan 18, 2025@03:41:55 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 ;