- 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 Feb 19, 2025@00:07:54 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