source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCTPU.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1SCMCTPU ;ALB/REW - Team Position Utilities ; 9 Jun 1995
2 ;;5.3;Scheduling;**41,130**;AUG 13, 1993
3 ;1
4ACTPTTM(SCPTTM,SCDT) ;is the patient- team assignment currently active?
5 ; Used by computed field #300 (CURRENTLY ACTIVE?) OF file #404.57
6 ; Input:
7 ; SCPTTM - Pointer to Patient Team Assignment file -404.42
8 ; SCDT - Date to check for, Default=DT
9 ; Returns
10 ; status^status change date
11 ; status:
12 ; 1 if after effective date and before inactive date
13 ; 0 if not yet active or inactivated already
14 ; -1 if error
15 ;999
16 ;new code
17 N SCOK,STATUS,EFFDT,SCNODE
18 S:'$D(SCDT) SCDT=DT
19 S SCNODE=$G(^SCPT(404.42,+SCPTTM,0))
20 ;no act=-1,dt before act=0,no inact=1,dt after inact=0,o/w=1
21 Q $S(('$P(SCNODE,U,2)):-1,(SCDT<$P(SCNODE,U,2)):0,('$P(SCNODE,U,9)):1,(SCDT>$P(SCNODE,U,9)):0,1:1)
22 ;
23ACTTP(SCTP,SCDT) ;is the team position currently active?
24 ; Used by computed field #300 (CURRENTLY ACTIVE?) OF file #404.57
25 ; Input:
26 ; SCTP - Pointer to Team Position file #404.57
27 ; SCDT - Date to check for, Default=DT
28 ; Returns
29 ; status^status change date
30 ; status:
31 ; 1 if after effective date and before inactive date
32 ; 0 if not yet active or inactivated
33 ; -1 if error
34 ;
35 ;new code
36 N SCX,STATUS,EFFDT
37 S:'$D(SCDT) SCDT=DT
38 S SCX=$$DATES^SCAPMCU1(404.59,SCTP,SCDT)
39 S STATUS=$P(SCX,U,1)
40 S EFFDT=$S(STATUS=0:$P(SCX,U,3),(STATUS=1):$P(SCX,U,2),1:"")
41QTACTTP Q STATUS_U_EFFDT
42 ;
43ITSCF(CRITERIA,REPORT,X) ;
44 ;Input transform for 404.93
45 ;CRITERIA - value of the .01 in 404.93 for entry DA
46 ;REPORT - value of the .02 in 404.93 for entry DA
47 ;X - value entered by user
48 ;X is killed if duplicate
49 ;
50 Q:'$G(DA)!'$D(X)
51 S:'$D(CRITERIA) CRITERIA=$P($G(^SD(404.93,DA,0)),U)
52 S:'$D(REPORT)#2 REPORT=$P($G(^SD(404.93,DA,0)),U,2)
53 I $D(^SD(404.93,"APRIM",CRITERIA,REPORT)) D
54 .D:'$G(DGQUIET) EN^DDIOL("Duplicate Criteria Not Allowed for Same Report","","?5")
55 .K X
56 Q
57 ;
58AKEY(REPORT,SORT,X) ;
59 ;Input transform for 404.92
60 ;REPORT - value of the .01 in 404.92 for entry DA
61 ;SORT - value of the .02 in 404.92 for entry DA
62 ;X - value entered by user
63 ;X is killed if duplicate
64 ;
65 Q:'$G(DA)!'$D(X)
66 S:'$D(REPORT) REPORT=$P($G(^SD(404.92,DA,0)),U)
67 S:'$D(SORT)#2 SORT=$P($G(^SD(404.92,DA,0)),U,2)
68 I $D(^SD(404.92,"AKEY",REPORT,SORT)) D
69 .D:'$G(DGQUIET) EN^DDIOL("Duplicate SORT BY TEXT Not Allowed for Same Report","","?5")
70 .K X
71 Q
72 ;
73IPTF(POSITION,TEAM,X) ;input transform for 404.57
74 ;kills x if duplicate
75 Q:'$G(DIUTIL)="VERIFY FIELDS"
76 Q:'$G(DA)!'$D(X)
77 S:'$D(POSITION) POSITION=$P($G(^SCTM(404.57,DA,0)),U,1)
78 S:'$D(TEAM)#2 TEAM=$P($G(^SCTM(404.57,DA,0)),U,2)
79 ;S:'$G(TEAM) TEAM=$O(^SCTM(404.51,"B",TEAM,0))
80 IF $D(^SCTM(404.57,"APRIMARY",POSITION,TEAM)) D
81 .D:'$G(DGQUIET) EN^DDIOL("Duplicate Team Positions Not Allowed","","?5")
82 .K X
83 Q
84OKACTTP(SCNODE,ACTDT) ;input transform for position assigned date for 404.43
85 ;
86 N OK
87 S OK=1
88 ;must have input defined
89 IF '$D(SCNODE)#2!('$G(ACTDT)) S OK=0_U_"Bad input data" G QTOKAC
90 ;if inactivation exists must be after activation
91 S:$P(SCNODE,U,4)&($P(SCNODE,U,4)<ACTDT) OK=0_U_"Inactivation date is after this date"
92 ;position must be active during assignment activation
93 S:'$$ACTTP(+$P(SCNODE,U,2),ACTDT) OK=0_U_"Position Not active on this date"
94 S:1>$$ACTPTTM(+$P(SCNODE,U,1),ACTDT) OK=0_U_"No active Patient Team Assignment on this date"
95QTOKAC Q OK
96OKINTP(SCNODE,INACTDT) ;input transform for inactivation date for 404.43
97 ;
98 N OK
99 S OK=1
100 ;must have input defined
101 IF '$D(SCNODE)#2!('$G(INACTDT)) S OK=0 G QTOKIN
102 ;must have activation date
103 S:'$P(SCNODE,U,3) OK=0_U_"No activation date in Pt Team Assignment"
104 ;activation date can't be after inactivation
105 S:$P(SCNODE,U,3)>INACTDT OK=0_U_"Activation date is after this date"
106 ;inactivation must be during time when position is active
107 S:'$$ACTTP(+$P(SCNODE,U,2),INACTDT) OK=0_U_"Inactivation date must be when position is active"
108QTOKIN Q OK
109 ;
110OKTP(DA,SCX) ;used by team position field of 404.43
111 N OK,SCTM,SCPTTMA,SCNODE
112 S SCNODE=$G(^SCPT(404.43,DA,0))
113 S OK=1
114 ;must have input defined
115 IF '$D(SCNODE)#2!('$G(SCX)) S OK=0 G QTOKTP
116 S SCTM=$P($G(^SCTM(404.57,SCX,0)),U,2)
117 S SCPTTMA=$P(SCNODE,U,1)
118 S:$P($G(^SCPT(404.42,SCPTTMA,0)),U,3)'=SCTM OK=0_U_"Team Position Must be from Team in Pt Team Assignment"
119QTOKTP Q OK
120 ;
121OKROLE(DA,SCX) ;used by role .05 field of 404.43
122 N OK,SCNODE,SCPTTMA,SCPC
123 S SCNODE=$G(^SCPT(404.43,DA,0))
124 S OK=1
125 ;must have input defined
126 IF '$D(SCNODE)#2!('$D(SCX)) S OK=0_U_"Undefined Patient Team Data" G QTOKTP
127 S SCPTTMA=$P(SCNODE,U,1)
128 S:$P($G(^SCPT(404.42,SCPTTMA,0)),U,8)=1 SCPC=1
129 ;if not a pc team & role is a pc role - not ok
130 S:('$G(SCPC))&$G(SCX) OK=0_U_"PC Roles only allowed if Pt Team Assignment is for Primary Care"
131QTOKRL Q OK
132 ;
133USEUSR() ;should user class functionality be employed?
134 ; Returned [1=Use USR Class,0=Don't)
135 Q +$G(^SD(404.91,1,"PCMM"))
136 ;
137ACCLIN(SC44,DATE) ;is clinic active on this date?
138 ; Return: 1=Yes,0=N0
139 N SCX
140 S SCX=+$G(^SC(+$G(SC44),"I"))
141 Q $S('SCX:1,(SCX>DATE):1,1:0)
Note: See TracBrowser for help on using the repository browser.