SCMCTPU2 ;ALB/REW - Team Position Utilities ; 9 Jun 1995
;;5.3;Scheduling;**41,148,204,564**;AUG 13, 1993;Build 8
;1
YSPTTPPC(DFN,SCACT,SCROLE) ;is it ok to give patient a new pc position
;
; Return [OK:1,Not OK: 0^Message]
Q:"2^1"'[$G(SCROLE) "0^Bad PC Role"
N SCOK,SCX,SCTP,SCROLETX
S SCROLETX=$S(SCROLE=1:"Practitioner",(SCROLE=2):"Attending",1:"Error")
;does pt have a current pc position?
S SCTP=$$GETPCTP^SCAPMCU2(DFN,DT,SCROLE)
IF SCTP>0 S SCOK="0^Pt has current PC "_SCROLETX_" Position Assignment"_U_SCTP G QTOKPC
;does pt have a future pc position?
S SCX=$O(^SCPT(404.43,"APCPOS",DFN,SCROLE,SCACT))
IF SCX D G QTOKPC
.S SCTP=$O(^SCPT(404.43,"APCPOS",DFN,SCROLE,+SCX,0))
.S SCOK="0^Patient has future PC Assignment to the "_$P($G(^SCTM(404.57,+SCTP,0)),U,1)_" position."_U_SCTP
S SCOK=1
QTOKPC Q SCOK
;
OKACPTTP(DFN,SCTP,DATE,ACTIVE) ;is it ok to activate pt pos assignment?
N SCOK,SCDT,SCNODE,SCINACT
S SCOK=1
G:'$D(^SCPT(404.43,"ADFN",DFN)) ENDOK ;quick check
;is position active now(if checking)?
IF $G(ACTIVE) D G:'SCOK ENDOK
. S SCOK=+$$ACTTP^SCMCTPU(SCTP,DATE)
;is the patient assigned to this position either now or in future?
S SCDT=$O(^SCPT(404.43,"ADFN",DFN,SCTP,3990101),-1)
S SCPTTP=$O(^SCPT(404.43,"ADFN",DFN,SCTP,+SCDT,0))
IF SCPTTP D
.S SCNODE=$G(^SCPT(404.43,SCPTTP,0))
.S SCINACT=$P(SCNODE,U,4)
.IF ('SCINACT)!(SCINACT>DATE) D
..S SCOK=0 ;no inactive date or inact after date
ENDOK Q SCOK
;
PCRLPTTP(DFN,SCTP,DATE) ; can position be pc practitioner or pc attending
; return yes pract^yes attend
Q $$CHKROLE(DFN,SCTP,DATE,1)_U_$$CHKROLE(DFN,SCTP,DATE,2)
;
CHKROLE(DFN,SCTP,DATE,ROLE) ;can position file role for patient?
;this is not a stand-alone function
N SCCUR,SCDT,SCTPRL,SCPTTP,SCOK,SCNODE,SCINACT,SCACT
S SCOK=1
;bp/cmf 204 change code begin
;original code next line
;IF $G(ROLE)&('$P($G(^SCTM(404.57,+$G(SCTP),0)),U,4)) S SCOK=0 G QTCHKRL
;bp/cmf 204 new code begin
;bp/cmf 204 new code end
I $G(ROLE) D G:SCOK=0 QTCHKRL
. I '$P($G(^SCTM(404.57,+$G(SCTP),0)),U,4) S SCOK=0 Q
. N SCTM
. S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
. I $P($G(^SCTM(404.51,SCTM,0)),U,5)'=1 S SCOK=0
. Q
;bp/cmf 204 change code end
S SCDT=$O(^SCPT(404.43,"APCPOS",DFN,ROLE,3990101),-1)
S SCTPRL=$O(^SCPT(404.43,"APCPOS",DFN,ROLE,+SCDT,0))
S SCPTTP=$O(^SCPT(404.43,"APCPOS",DFN,ROLE,+SCDT,+SCTPRL,0))
;check if hanging cross-reference - SD/564
I SCPTTP>0,'$D(^SCPT(404.43,SCPTTP,0)) D Q SCOK
.K ^SCPT(404.43,"APCPOS",DFN,ROLE,+SCDT,+SCTPRL,SCPTTP)
;
;check if active
IF SCPTTP D
.S SCNODE=$G(^SCPT(404.43,SCPTTP,0))
.S SCACT=$P(SCNODE,U,3)
.Q:(DATE=SCACT)&(SCTP=SCTPRL) ;if this date & position (editing current
.S SCINACT=$P(SCNODE,U,4)
.IF SCINACT D
..IF SCINACT>DATE D
...S SCOK=0 ;no making pc role before currently defined
.ELSE D
..S SCOK=0 ;no making pc role without inactivating current
QTCHKRL Q SCOK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTPU2 2976 printed Apr 09, 2024@21:52:13 Page 2
SCMCTPU2 ;ALB/REW - Team Position Utilities ; 9 Jun 1995
+1 ;;5.3;Scheduling;**41,148,204,564**;AUG 13, 1993;Build 8
+2 ;1
YSPTTPPC(DFN,SCACT,SCROLE) ;is it ok to give patient a new pc position
+1 ;
+2 ; Return [OK:1,Not OK: 0^Message]
+3 if "2^1"'[$GET(SCROLE)
QUIT "0^Bad PC Role"
+4 NEW SCOK,SCX,SCTP,SCROLETX
+5 SET SCROLETX=$SELECT(SCROLE=1:"Practitioner",(SCROLE=2):"Attending",1:"Error")
+6 ;does pt have a current pc position?
+7 SET SCTP=$$GETPCTP^SCAPMCU2(DFN,DT,SCROLE)
+8 IF SCTP>0
SET SCOK="0^Pt has current PC "_SCROLETX_" Position Assignment"_U_SCTP
GOTO QTOKPC
+9 ;does pt have a future pc position?
+10 SET SCX=$ORDER(^SCPT(404.43,"APCPOS",DFN,SCROLE,SCACT))
+11 IF SCX
Begin DoDot:1
+12 SET SCTP=$ORDER(^SCPT(404.43,"APCPOS",DFN,SCROLE,+SCX,0))
+13 SET SCOK="0^Patient has future PC Assignment to the "_$PIECE($GET(^SCTM(404.57,+SCTP,0)),U,1)_" position."_U_SCTP
End DoDot:1
GOTO QTOKPC
+14 SET SCOK=1
QTOKPC QUIT SCOK
+1 ;
OKACPTTP(DFN,SCTP,DATE,ACTIVE) ;is it ok to activate pt pos assignment?
+1 NEW SCOK,SCDT,SCNODE,SCINACT
+2 SET SCOK=1
+3 ;quick check
if '$DATA(^SCPT(404.43,"ADFN",DFN))
GOTO ENDOK
+4 ;is position active now(if checking)?
+5 IF $GET(ACTIVE)
Begin DoDot:1
+6 SET SCOK=+$$ACTTP^SCMCTPU(SCTP,DATE)
End DoDot:1
if 'SCOK
GOTO ENDOK
+7 ;is the patient assigned to this position either now or in future?
+8 SET SCDT=$ORDER(^SCPT(404.43,"ADFN",DFN,SCTP,3990101),-1)
+9 SET SCPTTP=$ORDER(^SCPT(404.43,"ADFN",DFN,SCTP,+SCDT,0))
+10 IF SCPTTP
Begin DoDot:1
+11 SET SCNODE=$GET(^SCPT(404.43,SCPTTP,0))
+12 SET SCINACT=$PIECE(SCNODE,U,4)
+13 IF ('SCINACT)!(SCINACT>DATE)
Begin DoDot:2
+14 ;no inactive date or inact after date
SET SCOK=0
End DoDot:2
End DoDot:1
ENDOK QUIT SCOK
+1 ;
PCRLPTTP(DFN,SCTP,DATE) ; can position be pc practitioner or pc attending
+1 ; return yes pract^yes attend
+2 QUIT $$CHKROLE(DFN,SCTP,DATE,1)_U_$$CHKROLE(DFN,SCTP,DATE,2)
+3 ;
CHKROLE(DFN,SCTP,DATE,ROLE) ;can position file role for patient?
+1 ;this is not a stand-alone function
+2 NEW SCCUR,SCDT,SCTPRL,SCPTTP,SCOK,SCNODE,SCINACT,SCACT
+3 SET SCOK=1
+4 ;bp/cmf 204 change code begin
+5 ;original code next line
+6 ;IF $G(ROLE)&('$P($G(^SCTM(404.57,+$G(SCTP),0)),U,4)) S SCOK=0 G QTCHKRL
+7 ;bp/cmf 204 new code begin
+8 ;bp/cmf 204 new code end
+9 IF $GET(ROLE)
Begin DoDot:1
+10 IF '$PIECE($GET(^SCTM(404.57,+$GET(SCTP),0)),U,4)
SET SCOK=0
QUIT
+11 NEW SCTM
+12 SET SCTM=$PIECE($GET(^SCTM(404.57,SCTP,0)),U,2)
+13 IF $PIECE($GET(^SCTM(404.51,SCTM,0)),U,5)'=1
SET SCOK=0
+14 QUIT
End DoDot:1
if SCOK=0
GOTO QTCHKRL
+15 ;bp/cmf 204 change code end
+16 SET SCDT=$ORDER(^SCPT(404.43,"APCPOS",DFN,ROLE,3990101),-1)
+17 SET SCTPRL=$ORDER(^SCPT(404.43,"APCPOS",DFN,ROLE,+SCDT,0))
+18 SET SCPTTP=$ORDER(^SCPT(404.43,"APCPOS",DFN,ROLE,+SCDT,+SCTPRL,0))
+19 ;check if hanging cross-reference - SD/564
+20 IF SCPTTP>0
IF '$DATA(^SCPT(404.43,SCPTTP,0))
Begin DoDot:1
+21 KILL ^SCPT(404.43,"APCPOS",DFN,ROLE,+SCDT,+SCTPRL,SCPTTP)
End DoDot:1
QUIT SCOK
+22 ;
+23 ;check if active
+24 IF SCPTTP
Begin DoDot:1
+25 SET SCNODE=$GET(^SCPT(404.43,SCPTTP,0))
+26 SET SCACT=$PIECE(SCNODE,U,3)
+27 ;if this date & position (editing current
if (DATE=SCACT)&(SCTP=SCTPRL)
QUIT
+28 SET SCINACT=$PIECE(SCNODE,U,4)
+29 IF SCINACT
Begin DoDot:2
+30 IF SCINACT>DATE
Begin DoDot:3
+31 ;no making pc role before currently defined
SET SCOK=0
End DoDot:3
End DoDot:2
+32 IF '$TEST
Begin DoDot:2
+33 ;no making pc role without inactivating current
SET SCOK=0
End DoDot:2
End DoDot:1
QTCHKRL QUIT SCOK
