source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTMU.m@ 724

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

initial load of WorldVistAEHR

File size: 5.1 KB
Line 
1SCMCTMU ;ALB/REW - Team-Patient Utilities ; 1 May 95
2 ;;5.3;Scheduling;**41**;AUG 13, 1993
3 ;1
4ACTTM(SCTM,SCDT) ;is the team currently active?
5 ; Used by computed field #300 (CURRENTLY ACTIVE?) OF file #404.51
6 ; Input:
7 ; SCTM - Pointer to Team file #404.51
8 ; SCDT - Date to check for, Default=DT
9 ; Returns:
10 ; 1 if after effective date and before inactive date
11 ; 0 if not yet active or inactivated
12 ; -1 if error
13 ;
14 Q $$DATES^SCAPMCU1(404.58,.SCTM,.SCDT)
15 ;
16ENROLL(DFN,CLINIC,DATE) ;is this patient enrolled in this clinic on a date?
17 ;Input:
18 ; DFN - ien of Patient file
19 ; CLINIC - Pointer to file 44
20 ; DATE - (Optional) Effective Date, default=DT
21 ;Return: [1|Yes, he is enrolled;0|he is not]
22 ;
23 N SCCL,SCL1,SCNODE,SCACT,SCINACT,SCYES
24 S SCYES=0
25 S SCCL=0
26 F S SCCL=$O(^DPT(DFN,"DE","B",CLINIC,SCCL)) Q:'SCCL D
27 .S SCCL1=0
28 .F S SCCL1=$O(^DPT(DFN,"DE",SCCL,1,SCCL1)) Q:'SCCL1 D
29 ..S SCNODE=$G(^DPT(DFN,"DE",SCCL,1,SCCL1,0))
30 ..S SCACT=+SCNODE
31 ..S SCINACT=$P(SCNODE,U,3)
32 ..S:$S('SCACT:0,(SCACT>DATE):0,'SCINACT:1,(SCINACT<DATE):0,1:1) SCYES=1
33 Q SCYES
34 ;
35RESTCONS(DFN) ;does this patient have restricted consults?
36 ; for a clinic in which the patient is NOT enrolled, some patients/teams
37 ; require more authority to enroll or make appointments
38 ; this will often be used with $$ENROLL(dfn) to see if he is enrolled
39 ;
40 ; Input: DFN - ien of Patient File
41 ; Return: [1|Yes, restrict 0|No
42 Q 1
43WHOCLIN(SDCL,DATE) ;give clinic & date return prt to 200
44 ; SDCL - ien of #44
45 ; DATE - effective date (optional) default =DT
46 ; Returned: ien of 200
47 ;
48 Q
49POSCLIN(SDCL,DATE) ;given clinic & date, return ptr to team position 404.57
50 ; SDCL - ien of Hospital Location (#44)
51 ; Returned: If exactly one position for clinic - ien of team postion
52 ; else null
53 ;
54 N X,SCD
55 S:'$G(DATE) DATE=DT
56 S SCD=$O(^SCTM(404.57,"ACLINDT",+SDCL,-DATE)) ;SCD is the effective date
57 S X=$O(^SCTM(404.57,"ACLINDT",+SDCL,+SCD,"")) ;position assoc w/ clinic
58 Q $G(X)
59WHOPOS(SCTP,DATE) ;given position & date,return pointer to 200^name of pr
60 ;SCTP - ien of Team Position File (#404.57)
61 ; Date - (Optional) effective date - default=today
62 ;
63 Q $$GETPRTP^SCAPMCU2(SCTP,.DATE)
64DISPWHO(SCPOS,DATE) ;given position & date, return external of 200
65 ;SCPOS - ien of 404.48)
66 ; DATE - (Optional) effective date - default=today
67 ;
68 N Y,SCP
69 S:'$G(DATE) DATE=DT
70 S SCP=$$WHOPOS(SCPOS,DATE)
71 S:SCP Y=$S($D(^VA(200,+SCP,0)):$P(^(0),U,1),1:"Unknown")
72 Q $G(Y)
73PR(SDNPI) ;Provider Display Data
74 ; Input -- SDNPI New Person IEN
75 ; Output -- Provider Display Data - Provider Name
76 N Y
77 S Y=$S($D(^VA(200,SDNPI,0)):$P(^(0),"^"),1:"Unknown")
78 Q $G(Y)
79PTTMSCRN ;define dic('s') to ensure patient team position assignement is ok
80 ;
81CK N SCTM,SCTMA
82 S SCTMA=$P($G(^SCPT(404.43,Y,0)),U,1)
83 S SCTM=$P($G(^SCPT(404.42,SCTMA,0)),U,3)
84 S DIC("S")="IF $D(^SCTM(404.57,""C"","_SCTM_",Y))"
85 Q
86OKPTTM(SCNODE,DA) ;check pt team assignment - 404.42
87 ; SCNODE is proposed new node
88 Q 1
89 N OK,DFN,SCTM,SCACT,SCINACT,SCDTS,SCTMHIST,SCB4,SCAFT
90 S OK=1
91 G:'DA QTOKTM
92 S DFN=$P(SCNODE,U,1)
93 S SCTM=$P(SCNODE,U,3)
94 S SCACT=$P(SCNODE,U,2)
95 S SCINACT=$P(SCNODE,U,9)
96 S:$G(SCACT) SCDTS("BEGIN")=SCACT
97 S:$D(SCACT) SCDTS("END")=$S(SCINACT:SCINACT,1:3990101)
98 S:$D(SCDTS) SCDTS("INCL")=1
99 ;check patient (.01) - none now
100 ;check team (.03)
101 IF SCINACT&('SCACT) S OK=0_U_"Activation must be defined before Discharge" G QTOKTM
102 IF SCTM&SCACT&DFN D
103 .S SCTMHIST=$$ACTHIST^SCAPMCU2(404.58,.SCTM,.SCDTS)
104 .S:'SCTMHIST OK=0_U_"Team Not Active"
105 .;check assignment dt (.02)
106 .; - is there an assignment on exactly the same date in 404.42?
107 .S SCPTTMA=0 F S SCPTTMA=$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,SCPTTMA)) Q:SCPTTMA=""!(SCPTTMA=DA)!(DA="") S OK=0_U_"Already an activation for patient/team on this date"
108 .; - is there an assignment w/o a discharge before in 404.42?
109 .S SCB4=$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT))
110 .S SCB4A=$O(^SCPT(404.42,"AIDT",DFN,SCTM,+SCB4,0))
111 .S:SCB4A&('$P($G(^SCPT(404.42,+SCB4A,0)),U,9)) OK=0_U_"Existing active patient/team assignment already"
112 .;check inactivation dt (.09)
113 .; - if exists, is inactivation after assignment dt
114 .S:SCINACT&(SCACT'<SCINACT) OK=0_U_"Activation must be before discharge"
115 .; - if there is a future assignment is it after this inactivation?
116 .S SCAFT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCINACT),-1)
117 .S:SCAFT&(SCAFT'>SCINACT) OK=0_U_"Existing future activation before this inactivation"
118QTOKTM Q OK
119 ;
120INSTPCTM(DFN,SCEFF) ;return institution & team for pt's pc team
121 ; return ptr4^institution^sctm^team name
122 N SCTM,SCINST,SCOK
123 S SCOK=0
124 S SCTM=+$$GETPCTM^SCAPMCU2(.DFN,.SCEFF,1)
125 S SCINST=+$P($G(^SCTM(404.51,+$G(SCTM),0)),U,7)
126 S:SCTM&SCINST SCOK=1
127 Q $S('SCOK:0,1:SCTM_U_$P($G(^SCTM(404.51,SCTM,0)),U,1)_U_SCINST_U_$P($G(^DIC(4,SCINST,0)),U,1))
128 ;
129EVT(SCCVEVT,SCCVORG) ;Invoke encounter conversion event driver
130 ; Input -- SCCVEVT Conversion event
131 ; 0=Estimate, 1=Convert, 2=Re-convert
132 ; SCCVORG Originating process type
133 ; Output -- ^TMP("SCCVEVT",$J, disposition array
134 K DTOUT,DIROUT
135 S X=+$O(^ORD(101,"B","SCMC ENCOUNTER CONVERSION EVENTS",0))_";ORD(101,"
136 I X D EN^XQOR
137 K X,^TMP("SCCVEVT",$J)
138EVTQ Q
Note: See TracBrowser for help on using the repository browser.