source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTMU2.m@ 1185

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

initial load of FOIAVistA 6/30/08 version

File size: 2.4 KB
Line 
1SCMCTMU2 ;ALB/REW - Team-Patient Utilities ; 1 Apr 96
2 ;;5.3;Scheduling;**41,51,148**;AUG 13, 1993
3 ;1
4RESTENR ;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
9END Q
10 ;
11YSPTTMPC(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
23QTOKPC Q SCOK
24 ;
25OKACPTTM(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
41ENDOKTM Q SCOK
42 ;
43OKPTTMPC(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)
54QTOKTM Q SCOK
55 ;
56OKINPTTM(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
Note: See TracBrowser for help on using the repository browser.