232 lines
7.1 KiB
Mathematica
232 lines
7.1 KiB
Mathematica
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;;
|
|
;
|