source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP3.m@ 1093

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

revised back to 6/30/08 version

File size: 4.6 KB
Line 
1SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM
2 ;;5.3;Scheduling;**41,48,98,177,231,433**;AUG 13, 1993
3 ;
4 ;List of Team's Patients Report
5 ;
6HITS(ARRY,TIEN) ;
7 ;ARRY - list of patients for a given team
8 ;TIEN - team ien
9 ;
10 N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT
11 N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE
12 N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN
13 S INACTIVE=0
14 S NXT=0
15 F S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N) D
16 .S NODE=$G(@ARRY@(NXT))
17 .Q:NODE=""
18 .S PTIEN=+$P(NODE,"^") ;patient ien
19 .S PTNAME=$P(NODE,"^",2) ;patient name
20 .S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42)
21 .;
22 .S PNODE=$G(^DPT(PTIEN,0))
23 .Q:PNODE=""
24 .S DFN=PTIEN
25 .D PID^VADPT6
26 .S PID=VA("BID")
27 .;
28 .S TPA=$$TPAR(PTAI,"")
29 .I TPA'=-1 D
30 ..S PIEN=$P(TPA,"^")
31 ..S PNAME=$P(TPA,"^",2)
32 ..S CNAME=$P(TPA,"^",3)
33 ..S LAST=$P(TPA,"^",4)
34 ..S NEXT=$P(TPA,"^",5)
35 ..;
36 ..S FLAG="Y"
37 ..S TINFO=$$TINF^SCRPTP(TIEN) ;team information
38 ..S INST=+$P(TINFO,"^") ;institution ien
39 ..S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
40 ..S PHONE=$P(TINFO,"^",4) ;team phone
41 ..S PC=$P(TINFO,"^",3) ;primary care?
42 ..S TNAME=$P(TINFO,"^",2) ;team name
43 ..;
44 ..D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
45 ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT)
46 .;
47 .;check for other assignments
48 .N TPIN
49 .S CNT=""
50 .F S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N) D
51 ..S TPIN=$$TPAR(PTAI,CNT)
52 ..Q:TPIN=-1
53 ..S PIEN=$P(TPIN,"^")
54 ..S PNAME=$P(TPIN,"^",2)
55 ..S CNAME=$P(TPIN,"^",3)
56 ..S LAST=$P(TPIN,"^",4)
57 ..S NEXT=$P(TPIN,"^",5)
58 ..S ROLN=$P(TPIN,U,6)
59 ..S PCAP=$P(TPIN,U,7)
60 ..I '$D(FLAG) D
61 ...S TINFO=$$TINF^SCRPTP(TIEN) ;team information
62 ...S INST=+$P(TINFO,"^") ;institution ien
63 ...S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
64 ...S PHONE=$P(TINFO,"^",4) ;team phone
65 ...S PC=$P(TINFO,"^",3) ;primary care?
66 ...S TNAME=$P(TINFO,"^",2) ;team name
67 ...;
68 ...D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
69 ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP)
70 I INACTIVE S @STORE@(INST,TIEN,"INACT")=""
71 Q
72 ;
73TPAR(PTAI,START) ;
74 N PTPA,TPIEN,TPNODE,ROL,CNAME,CIEN,ENROLL,OKAY,PNAME,NEXT,LAST,PAIEN
75 N ROLN,PCAP
76 I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]"
77 ; ^ no patient team position assignment
78 IF START="" D
79 .S PTPA=$O(^SCPT(404.43,"B",PTAI,START))
80 ELSE D
81 .S PTPA=START
82 I PTPA="" Q "0^[Not Assigned]"
83 S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team position assignment node
84 I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]"
85 I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)<DT Q -1
86 S TPIEN=+$P(PTPAN,"^",2) ;team position ien (#404.57)
87 I '$D(^SCTM(404.57,TPIEN,0)) Q "0^[Not Assigned]"
88 S TPNODE=$G(^SCTM(404.57,TPIEN,0))
89 I TPNODE="" Q "0^[Not Assigned]"
90 S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
91 Q:'$D(ROLE(ROL))&(ROLE'=1) -1
92 ; ^ not a selected role
93 S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
94 ;
95 S PCAP=$S($P(PTPAN,U,5)<1:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ;PC?
96 ;
97 S CIEN=+$P(TPNODE,"^",9) ;associated clinic ien
98 S CNAME=$P($G(^SC(CIEN,0)),"^") ;clinic name
99 ;check patient status
100 S OKAY=""
101 I CIEN>0&(PSTAT'=1) S OKAY=$$PST^SCRPTP(PTIEN,CIEN)
102 Q:(CIEN>0)&('OKAY)&(PSTAT'=1) -1
103 ; ^ not selected patient status
104 ;
105 ;next two lines commented off - SD*5.3*433
106 ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic
107 ;I 'ENROLL S CNAME="",CIEN=0
108 ;
109 S PAIEN=$$CHK(TPIEN)
110 I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name
111 ;SD*5.3*231
112 I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]"
113 ;
114 S (NEXT,LAST)=""
115 I +CIEN>0 S NEXT=$$GETNEXT^SCRPU3(PTIEN,CIEN) ;next appointment
116 I +CIEN>0 S LAST=$$GETLAST^SCRPU3(PTIEN,CIEN) ;last appointment
117 ;
118 Q PIEN_U_PNAME_U_CNAME_U_LAST_U_NEXT_U_ROLN_U_PCAP
119 ;
120ENRL(PTIEN,CLIEN) ;
121 ;
122 N FOUND,ENODE,EN,NXT
123 S FOUND=0
124 Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
125 S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
126 Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
127 S NXT=""
128 F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D
129 .;check if active enrollment
130 .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
131 .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q ;not active enrollment
132 .; ^ discharge date ^ enrollment date
133 .S FOUND=1
134 Q FOUND
135 ;
136CHK(TPIEN) ;assigned to a position
137 ;TPIEN - ien of 404.57 Team Position file
138 ;returns: ien of 200 New Person file
139 N EN,PLIST,PERR,ERR,NAME
140 S PLIST="PLST",PERR="PRR"
141 K @PLIST,@PERR
142 S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR)
143 I '$D(@PERR) D
144 .S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file
145 .S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name
146 K @PLIST,@PERR
147 Q EN_"^"_NAME
148 ;
Note: See TracBrowser for help on using the repository browser.