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

SCMCLK.m

Go to the documentation of this file.
  1. SCMCLK ;bp/cmf - Preceptor History Functions ; Sep 1999
  1. ;;5.3;Scheduling;**177,204**;AUG 13, 1993
  1. ;
  1. ; - $$OKPREC functions
  1. ; - input variables (required)
  1. ; scien := pointer to 404.57 (precepted ien)
  1. ; scpien := pointer to 404.57 (preceptor ien)
  1. ; sclnkdt := date to test
  1. ; - output
  1. ; $p1 := 1=assignment ok
  1. ; 0=not
  1. ; $p2 := if not, reason code
  1. ; $p3 := if not, reason
  1. ;
  1. OKPREC(SCIEN,SCPIEN,SCLNKDT) ;
  1. ;
  1. S SCIEN=+$G(SCIEN,0)
  1. S SCPIEN=+$G(SCPIEN,0)
  1. S SCLNKDT=+$G(SCLNKDT,0)
  1. I (SCIEN<1)!(SCPIEN<1)!(SCLNKDT<1) Q $$S(8)
  1. ;
  1. I SCIEN=SCPIEN Q $$S(1)
  1. ;
  1. N SCX,SCY,SCPAH,SCPAHA
  1. I '$D(^SCTM(404.57,SCIEN,0)) Q $$S(8)
  1. S SCX=$G(^SCTM(404.57,SCIEN,0))
  1. I '$D(^SCTM(404.57,SCPIEN,0)) Q $$S(8)
  1. S SCY=^SCTM(404.57,SCPIEN,0)
  1. I $P(SCX,U,2)'=$P(SCY,U,2) Q $$S(2)
  1. ;
  1. D DTARY(0)
  1. S SCPAH=$$VALHIST^SCAPMCU5(404.53,SCPIEN,"SCPAHA")
  1. I $$ACTHIST^SCAPMCU5("SCPAHA","SCLNKDT") Q $$S(3)
  1. ;I $$ACTHIST^SCAPMCU2(404.53,SCPIEN,"SCLNKDT") Q $$S(3)
  1. ;
  1. I '+$P(SCY,U,12) Q $$S(4)
  1. ;
  1. I +$P(SCX,U,4),'+$P(SCY,U,4) Q $$S(5)
  1. ;
  1. I $$ACTHIST^SCAPMCU2(404.59,SCPIEN,"SCLNKDT")<1 Q $$S(6)
  1. ;
  1. I $$CHKPRTP() Q $$S(9)
  1. ;
  1. Q 1
  1. ;
  1. OKPREC1(SCPIEN,SCLNKDT) ;
  1. ; ; prevent preceptor assignment danglers
  1. ; ; should also return array of danglers, if any,
  1. ; ; for a cleanup function, but not asked for yet
  1. ;
  1. ;
  1. S SCPIEN=+$G(SCPIEN,0)
  1. S SCLNKDT=+$G(SCLNKDT,0)
  1. I (SCPIEN<1)!(SCLNKDT<1) Q $$S(8)
  1. I '$D(^SCTM(404.53,"AD",SCPIEN)) Q 1
  1. ;
  1. N SCX,SCN
  1. D DTARY(1)
  1. K ^TMP("SCPHIS",$J)
  1. S SCX=$$PRECHIS(SCPIEN,"SCLNKDT","^TMP(""SCPHIS"",$J)")
  1. K ^TMP("SCPHIS",$J)
  1. ;
  1. Q $S(SCX>0:$$S(7),1:1)
  1. ;
  1. OKPREC2(SCIEN,SCLNKDT) ; return preceptor ien^name, if any
  1. ; ; used for computed field 306 of file 404.57
  1. ;
  1. ;
  1. S SCIEN=+$G(SCIEN,0)
  1. S SCLNKDT=+$G(SCLNKDT,0)
  1. I (SCIEN<1)!(SCLNKDT<1) Q $$S(8)
  1. N SCX,SCP2,SCP3,SCPIEN,SCLNKLI,SCLNKER,SCPAH,SCPAHA
  1. D DTARY(0)
  1. S SCPAH=$$VALHIST^SCAPMCU5(404.53,SCIEN,"SCPAHA")
  1. S SCX=$$ACTHIST^SCAPMCU5("SCPAHA","SCLNKDT")
  1. ;S SCX=$$ACTHIST^SCAPMCU2(404.53,SCIEN,"SCLNKDT")
  1. I +SCX<1 Q ""
  1. S SCP2=$P(SCX,U,2)
  1. I +SCP2<1 Q ""
  1. S SCP3=$P(SCX,U,3)
  1. I '$D(^SCTM(404.53,SCP3,0)) Q $$S(8)
  1. S SCPIEN=$P(^SCTM(404.53,SCP3,0),U,6)
  1. Q $$GETPRTP^SCAPMCU2(SCPIEN,SCLNKDT)
  1. ;
  1. OKPREC3(SCIEN,SCLNKDT) ; return preceptor position ien^name, if any
  1. ; ; used for computed field 305 of file 404.57
  1. ;
  1. ;
  1. S SCIEN=+$G(SCIEN,0)
  1. S SCLNKDT=+$G(SCLNKDT,0)
  1. I (SCIEN<1)!(SCLNKDT<1) Q $$S(8)
  1. N SCX,SCP2,SCP3,SCPIEN,SCLNKER,SCPAH,SCPAHA
  1. D DTARY(0)
  1. S SCPAH=$$VALHIST^SCAPMCU5(404.53,SCIEN,"SCPAHA")
  1. S SCX=$$ACTHIST^SCAPMCU5("SCPAHA","SCLNKDT")
  1. ;S SCX=$$ACTHIST^SCAPMCU2(404.53,SCIEN,"SCLNKDT")
  1. I +SCX<1 Q ""
  1. S SCP2=$P(SCX,U,2)
  1. I +SCP2<1 Q ""
  1. S SCP3=$P(SCX,U,3)
  1. I '$D(^SCTM(404.53,SCP3,0)) Q $$S(8)
  1. S SCPIEN=$P(^SCTM(404.53,SCP3,0),U,6)
  1. Q SCPIEN_U_$$EXT^SCAPMCU2(404.53,SCPIEN)
  1. ;
  1. OKPREC4(SCIEN) ; return if precepted position can be un-precepted
  1. ; ; if patient assign after 1st preceptment date, NO
  1. ; ; used by computed field #400 of file 404.57
  1. S SCIEN=$G(SCIEN,0)
  1. I (SCIEN<1)!('$D(^SCTM(404.57,SCIEN))) Q $$S(8)
  1. I '$D(^SCTM(404.53,"B",SCIEN)) Q 1
  1. ;
  1. N SCVALHIS,SCDT,SCX
  1. S SCDT=$P($$VALHIST^SCAPMCU5(404.53,SCIEN,"SCVALHIS"),U,2)
  1. I SCDT=0 Q 1
  1. S SCX=$$PCPOSCNT^SCAPMCU1(SCIEN,SCDT,0,1)
  1. Q $S(SCX>0:$$S(10),1:1)
  1. ;
  1. OKPREC5(SCIEN,SCLNKDT) ; if position has a preceptor,
  1. ; ; is preceptor link valid?
  1. ;
  1. S SCIEN=$G(SCIEN,0)
  1. S SCLNKDT=$G(SCLNKDT,DT)
  1. I (SCIEN<1)!(SCLNKDT<1) Q $$S(8)
  1. N SCPIEN
  1. S SCPIEN=+$$OKPREC3(SCIEN,SCLNKDT)
  1. I SCPIEN<1 Q 1
  1. Q $$OKPREC(SCIEN,SCPIEN,SCLNKDT)
  1. ;
  1. PRECHIS(SCPIEN,SCDATES,SCLIST) ;return precepted positions for preceptor
  1. ; input
  1. ; SCPIEN := preceptor pos ien (404.57) (required)
  1. ; SCDATES := standard PCMM date array (required)
  1. ; SCDATES(begin) := start date [default = DT]
  1. ; SCDATES(end) := end date [default = DT]
  1. ; SCDATES(incl) := always set to 0
  1. ; SCLIST := output array (required)
  1. ;
  1. ; output
  1. ; @SCLIST@(scn)
  1. ; format :=
  1. ; pieces 1-13: same as SCLIST(scn,) node of $$prtp^scapmc8
  1. ; pieces 14-16: same as SCLIST(scn,'PR',) node of $$prtp^scapmc8
  1. ; @SCLIST@('SCPR',precepted team posn ien (404.57) +
  1. ; ,preceptor start date +
  1. ; ,preceptor asgn ien, +
  1. ; ,precepted posn asgn ien,scn)
  1. ;
  1. S SCPIEN=+$G(SCPIEN,0)
  1. S SCDATES=$G(SCDATES)
  1. S SCLIST=$G(SCLIST)
  1. I (SCPIEN<1)!(SCDATES']"")!(SCLIST']"") Q $$S(8)
  1. ;
  1. N SCN,SCPVAL,SCPN,SCIEN,SCX,SCXP,SCXPR,SCXARY,SCXDT
  1. N SCPTP,SCPTPN,SCBEGIN,SCEND,SCESEQ,SCLSEQ
  1. N SCP1P11,SCP12,SCP13,SCP14,SCP15,SCP16,SCR
  1. ;
  1. S (@SCDATES@("BEGIN"),SCBEGIN)=$G(@SCDATES@("BEGIN"),DT)
  1. S (@SCDATES@("END"),SCEND)=$G(@SCDATES@("END"),DT)
  1. S @SCDATES@("INCL")=0
  1. ;
  1. I '$D(^SCTM(404.53,"D",SCPIEN)) Q 0
  1. I '$D(^SCTM(404.53,"AD",SCPIEN)) Q 0
  1. S SCPN=0 ; incrementor
  1. S @SCLIST@(0)=0
  1. S SCIEN=0
  1. F S SCIEN=$O(^SCTM(404.53,"AD",SCPIEN,SCIEN)) Q:'SCIEN D
  1. . ;K SCXPR
  1. . ;S SCX=$$ACTHIST^SCAPMCU2(404.53,SCIEN,.SCDATES,"SCXER","SCXPR")
  1. . ;Q:+SCX<1
  1. . K SCPVAL(SCIEN)
  1. . S SCX=$$VALHIST^SCAPMCU5(404.53,SCIEN,"SCPVAL("_SCIEN_")")
  1. . Q:'$D(SCPVAL(SCIEN))
  1. . S SCX=$$ACTHIST^SCAPMCU5("SCPVAL("_SCIEN_")",.SCDATES)
  1. . Q:+SCX<1
  1. . ;
  1. . S SCX=0
  1. . F S SCX=$O(^SCTM(404.53,"AD",SCPIEN,SCIEN,1,SCX)) Q:'SCX D
  1. . . Q:'$D(SCPVAL(SCIEN,"I",SCX))
  1. . . S SCXARY=$O(SCPVAL(SCIEN,"I",SCX,0))
  1. . . S SCP14=$O(SCPVAL(SCIEN,SCXARY,0)) ;precept start dt
  1. . . S SCP16=$O(SCPVAL(SCIEN,SCXARY,SCP14,0)) ;precept start ien
  1. . . S SCP15=$P(SCPVAL(SCIEN,SCXARY,SCP14,SCP16),U)
  1. . . S SCP15=$S(+SCP15>1:SCP15,1:9999999) ;precept end dt
  1. . . Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,0,SCP14,SCP15)
  1. . . K SCPTP
  1. . . K SCXDT
  1. . . S SCXDT("BEGIN")=SCP14
  1. . . S SCXDT("END")=SCP15
  1. . . S SCXDT("INCL")=0
  1. . . S SCXP=$$PRTP^SCAPMC8(SCIEN,"SCXDT","SCPTP","SCPTPE")
  1. . . Q:+$G(SCPTP(0))<1
  1. . . F SCXP=1:1:SCPTP(0) D
  1. . . . S SCPN=SCPN+1
  1. . . . S SCP1P11=$P(SCPTP(SCXP),U,1,11)
  1. . . . S SCP12=$P(SCPTP(SCXP),U,12)
  1. . . . S SCP13=$P(SCPTP(SCXP),U,13)
  1. . . . S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14_U_SCP15_U_SCP16
  1. . . . S @SCLIST@(0)=SCPN
  1. . . . S @SCLIST@(SCPN)=SCR
  1. . . . S @SCLIST@("SCPR",SCIEN,SCP14,SCP16,$P(SCR,U,11),SCPN)=""
  1. . . . Q
  1. . . Q
  1. . K SCPVAL(SCIEN)
  1. . Q
  1. ;
  1. PRECQ Q @SCLIST@(0)>0
  1. ;
  1. DTARY(SCX) ;
  1. S SCLNKDT("BEGIN")=SCLNKDT
  1. S SCLNKDT("END")=$S(SCX=1:9999999,1:SCLNKDT)
  1. S SCLNKDT("INCL")=0
  1. ;I $G(SCLIST)]"" S SCLNKDT("END")=$G(SCLNKDT0,9999999)
  1. Q
  1. ;
  1. CHKPRTP() ;
  1. Q $$GETPRTP^SCAPMCU2(SCIEN,SCLNKDT)=$$GETPRTP^SCAPMCU2(SCPIEN,SCLNKDT)
  1. ;
  1. S(SCX) Q 0_U_SCX_U_$P($T(T+SCX),";;",2)_"."
  1. ;
  1. T ;;
  1. 1 ;;Position can't precept itself;;
  1. 2 ;;Preceptor and precepted must be on same team;;
  1. 3 ;;Preceptor can't have a preceptor on assignment date;;
  1. 4 ;;Preceptor must be able to act as a preceptor;;
  1. 5 ;;Preceptor must be PC if precepted is PC;;
  1. 6 ;;Preceptor must be active on assignment date;;
  1. 7 ;;Active or future precepted position(s);;
  1. 8 ;;Invalid Parameter
  1. 9 ;;Preceptor/Precepted Staff can't be the same;;
  1. 10 ;;Position has patient assignments after precepted date;;
  1. ;