source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTPU2.m@ 1147

Last change on this file since 1147 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1SCMCTPU2 ;ALB/REW - Team Position Utilities ; 9 Jun 1995
2 ;;5.3;Scheduling;**41,148,204**;AUG 13, 1993
3 ;1
4YSPTTPPC(DFN,SCACT,SCROLE) ;is it ok to give patient a new pc position
5 ;
6 ; Return [OK:1,Not OK: 0^Message]
7 Q:"2^1"'[$G(SCROLE) "0^Bad PC Role"
8 N SCOK,SCX,SCTP,SCROLETX
9 S SCROLETX=$S(SCROLE=1:"Practitioner",(SCROLE=2):"Attending",1:"Error")
10 ;does pt have a current pc position?
11 S SCTP=$$GETPCTP^SCAPMCU2(DFN,DT,SCROLE)
12 IF SCTP>0 S SCOK="0^Pt has current PC "_SCROLETX_" Position Assignment"_U_SCTP G QTOKPC
13 ;does pt have a future pc position?
14 S SCX=$O(^SCPT(404.43,"APCPOS",DFN,SCROLE,SCACT))
15 IF SCX D G QTOKPC
16 .S SCTP=$O(^SCPT(404.43,"APCPOS",DFN,SCROLE,+SCX,0))
17 .S SCOK="0^Patient has future PC Assignment to the "_$P($G(^SCTM(404.57,+SCTP,0)),U,1)_" position."_U_SCTP
18 S SCOK=1
19QTOKPC Q SCOK
20 ;
21OKACPTTP(DFN,SCTP,DATE,ACTIVE) ;is it ok to activate pt pos assignment?
22 N SCOK,SCDT,SCNODE,SCINACT
23 S SCOK=1
24 G:'$D(^SCPT(404.43,"ADFN",DFN)) ENDOK ;quick check
25 ;is position active now(if checking)?
26 IF $G(ACTIVE) D G:'SCOK ENDOK
27 . S SCOK=+$$ACTTP^SCMCTPU(SCTP,DATE)
28 ;is the patient assigned to this position either now or in future?
29 S SCDT=$O(^SCPT(404.43,"ADFN",DFN,SCTP,3990101),-1)
30 S SCPTTP=$O(^SCPT(404.43,"ADFN",DFN,SCTP,+SCDT,0))
31 IF SCPTTP D
32 .S SCNODE=$G(^SCPT(404.43,SCPTTP,0))
33 .S SCINACT=$P(SCNODE,U,4)
34 .IF ('SCINACT)!(SCINACT>DATE) D
35 ..S SCOK=0 ;no inactive date or inact after date
36ENDOK Q SCOK
37 ;
38PCRLPTTP(DFN,SCTP,DATE) ; can position be pc practitioner or pc attending
39 ; return yes pract^yes attend
40 Q $$CHKROLE(DFN,SCTP,DATE,1)_U_$$CHKROLE(DFN,SCTP,DATE,2)
41 ;
42CHKROLE(DFN,SCTP,DATE,ROLE) ;can position file role for patient?
43 ;this is not a stand-alone function
44 N SCCUR,SCDT,SCTPRL,SCPTTP,SCOK,SCNODE,SCINACT,SCACT
45 S SCOK=1
46 ;bp/cmf 204 change code begin
47 ;original code next line
48 ;IF $G(ROLE)&('$P($G(^SCTM(404.57,+$G(SCTP),0)),U,4)) S SCOK=0 G QTCHKRL
49 ;bp/cmf 204 new code begin
50 ;bp/cmf 204 new code end
51 I $G(ROLE) D G:SCOK=0 QTCHKRL
52 . I '$P($G(^SCTM(404.57,+$G(SCTP),0)),U,4) S SCOK=0 Q
53 . N SCTM
54 . S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
55 . I $P($G(^SCTM(404.51,SCTM,0)),U,5)'=1 S SCOK=0
56 . Q
57 ;bp/cmf 204 change code end
58 S SCDT=$O(^SCPT(404.43,"APCPOS",DFN,ROLE,3990101),-1)
59 S SCTPRL=$O(^SCPT(404.43,"APCPOS",DFN,ROLE,+SCDT,0))
60 S SCPTTP=$O(^SCPT(404.43,"APCPOS",DFN,ROLE,+SCDT,+SCTPRL,0))
61 ;check if active
62 IF SCPTTP D
63 .S SCNODE=$G(^SCPT(404.43,SCPTTP,0))
64 .S SCACT=$P(SCNODE,U,3)
65 .Q:(DATE=SCACT)&(SCTP=SCTPRL) ;if this date & position (editing current
66 .S SCINACT=$P(SCNODE,U,4)
67 .IF SCINACT D
68 ..IF SCINACT>DATE D
69 ...S SCOK=0 ;no making pc role before currently defined
70 .ELSE D
71 ..S SCOK=0 ;no making pc role without inactivating current
72QTCHKRL Q SCOK
Note: See TracBrowser for help on using the repository browser.