1 | SCMCTMU2 ;ALB/REW - Team-Patient Utilities ; 1 Apr 96
|
---|
2 | ;;5.3;Scheduling;**41,51,148**;AUG 13, 1993
|
---|
3 | ;1
|
---|
4 | RESTENR ;call when pt is set to 'restrict consults' & he is enrolled in clinic
|
---|
5 | G:'$G(DFN) END
|
---|
6 | S SCCL=0
|
---|
7 | F S SCCL=$O(^TMP($J,"SC CED","AFTER","B",SCCL)) Q:'SCCL D
|
---|
8 | .W !,SCCL
|
---|
9 | END Q
|
---|
10 | ;
|
---|
11 | YSPTTMPC(DFN,SCACT) ;is it ok to give patient a new pc team?
|
---|
12 | ; Return [OK:1,Not OK: 0^Message]
|
---|
13 | N SCOK,SCX,SCTM
|
---|
14 | ;does pt have a current pc team?
|
---|
15 | S SCTM=$$GETPCTM^SCAPMCU2(DFN,DT,1)
|
---|
16 | IF SCTM>0 S SCOK="0^Pt has current PC Team Assignment"_U_SCTM G QTOKPC
|
---|
17 | ;does pt have a future pc team?
|
---|
18 | S SCX=$O(^SCPT(404.42,"APCTM",DFN,1,SCACT))
|
---|
19 | IF SCX D G QTOKPC
|
---|
20 | .S SCTM=$O(^SCPT(404.42,"APCTM",DFN,1,+SCX,0))
|
---|
21 | .S SCOK="0^Patient has future PC Assignment to the "_$P($G(^SCTM(404.51,+SCTM,0)),U,1)_" team."_U_SCTM
|
---|
22 | S SCOK=1
|
---|
23 | QTOKPC Q SCOK
|
---|
24 | ;
|
---|
25 | OKACPTTM(DFN,SCTM,SCDATE,SCACTIVE) ;is patient active from now till forever?
|
---|
26 | ; Returned: 1: Not active from now till forever, 0 = Active sometime
|
---|
27 | ; DFN - Pointer to Patient File
|
---|
28 | ; SCTM - Team File ien of interest
|
---|
29 | ; SCDATE - Start Date
|
---|
30 | ; SCACTIVE- Must Team be active on date or just sometime in future?
|
---|
31 | N SCTMDT,SCOK,SCACERR,SCACLST
|
---|
32 | S SCOK=1
|
---|
33 | S SCTMDT("BEGIN")=$G(SCDATE,DT)
|
---|
34 | S SCTMDT("END")=3990101 ;forever
|
---|
35 | S SCTMDT("INCL")=0
|
---|
36 | S SCACTIVE=$G(SCACTIVE,1)
|
---|
37 | ; if checking for active teams
|
---|
38 | IF SCACTIVE&('$$ACTHIST^SCAPMCU2(404.58,.SCTM,.SCTMDT,"SCACERR","SCACLST")) S SCOK=0 G ENDOKTM
|
---|
39 | S SCOK=$$TMPT^SCAPMC(DFN,"SCTMDT",,"SCACLST","SCACERR")
|
---|
40 | S:SCOK>0&($D(SCACLST("SCTM",SCTM))) SCOK=0
|
---|
41 | ENDOKTM Q SCOK
|
---|
42 | ;
|
---|
43 | OKPTTMPC(DFN,SCTM,DATE) ;
|
---|
44 | N SCOK,SCPCTM
|
---|
45 | S SCOK=1
|
---|
46 | ;is this a possible pc team?
|
---|
47 | IF '$P($G(^SCTM(404.51,+$G(SCTM),0)),U,5) S SCOK=0 G QTOKTM
|
---|
48 | S SCPCTM=$$GETPCTM^SCAPMCU2(DFN,DATE,1)
|
---|
49 | IF SCPCTM D G QTOKTM
|
---|
50 | .IF SCPCTM'=SCTM D
|
---|
51 | ..S SCOK=0
|
---|
52 | ELSE D
|
---|
53 | .S SCOK=$$YSPTTMPC(DFN,DATE)
|
---|
54 | QTOKTM Q SCOK
|
---|
55 | ;
|
---|
56 | OKINPTTM(DFN,SCTM,SCINACT) ;no future pt-position assignments?
|
---|
57 | Q:'($G(DFN)&($G(SCTM))&($G(SCINACT))) 0
|
---|
58 | N SCTP,SCPTTPDT,SCPTTPI,SCPTTP0,OK
|
---|
59 | S SCTP=0,OK=1
|
---|
60 | F S SCTP=$O(^SCPT(404.43,"ADFN",DFN,SCTP)) Q:'SCTP D Q:'OK
|
---|
61 | .F SCPTTPDT=0:0 S SCPTTPDT=$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCPTTPDT)) Q:'SCPTTPDT D
|
---|
62 | ..S SCPTTPI=$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCPTTPDT,0))
|
---|
63 | ..S SCPTTP0=$G(^SCPT(404.43,SCPTTPI,0))
|
---|
64 | ..Q:$P($G(^SCTM(404.57,+$P(SCPTTP0,U,2),0)),U,2)'=SCTM ;ignore other teams
|
---|
65 | ..S:'$P(SCPTTP0,U,4) OK=0 ;all ptpos assignments must have inact date
|
---|
66 | ..S:$P(SCPTTP0,U,4)>SCINACT OK=0 ;all ptpos inact dates after tm inact
|
---|
67 | Q OK
|
---|