source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDPPTEM.m@ 1375

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1SDPPTEM ;BP-CIOFO/KEITH - Patient Profile Team Info ; 8/27/99 10:39am
2 ;;5.3;Scheduling;**41,177,297**;AUG 13, 1993
3 ;
4 ;Gathering Team Information for Patient Profile
5 ;
6TDATA(DFN,VALMCNT,SDATE,SDPRT,SDCOL) ;Team information - gather, format and optionally print.
7 ;Input: DFN=patient ifn
8 ;Input: VALMCNT=variable to return number of lines (pass by reference)
9 ;Input: SDATE=effective date (optional)
10 ;Input: SDPRT=print flag, 'P' for PC info only, 'A' for all (optional)
11 ;Input: SDCOL=column to print in conjunction with SDPRT flag (optional)
12 ;
13 Q:DFN'>0
14 N SDI,SDATE,SDLIST,SDX,SDLN,SDY,SDPH,SDTEAM,SDPTA,SDII,SDIII,SDZ
15 N SDTM,SDTMN,SDPO,SDPON,SDPR,SDPRN
16 N PAGER,PHONE
17 ;
18 F SDI="SDPLIST","SDTEMP" K ^TMP(SDI,$J)
19 S SDCOL=+$G(SDCOL),SDATE=$G(SDATE) S:SDATE<1 SDATE=DT
20 F SDI="BEGIN","END" S SDATE(SDI)=SDATE
21 S SDATE="SDATE",SDLIST="^TMP(""SDPLIST"",$J)",SDLN=2
22 ;
23 S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
24 ;
25 ;PC Team
26 S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"PCTM",SDI)) Q:'SDI D
27 .S SDX=$G(^TMP("SDPLIST",$J,DFN,"PCTM",SDI)) Q:'$L(SDX)
28 .S SDY=""
29 .D S1("Primary Care Team",$P(SDX,U,2))
30 .S SDPH=$P($G(^SCTM(404.51,+SDX,0)),U,2) D:$L(SDPH) S2("Phone",SDPH)
31 .S:$P(SDX,U,3) SDPTA($P(SDX,U,3))=""
32 .D STL(SDY)
33 .Q
34 ;
35 ;AP
36 S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"PCAP",SDI)) Q:'SDI D
37 .S SDX=$G(^TMP("SDPLIST",$J,DFN,"PCAP",SDI)) Q:'$L(SDX)
38 .S SDY=""
39 .D S1("Associate Provider",$P(SDX,U,2))
40 .D S2("Position",$P(SDX,U,4))
41 .D STL(SDY)
42 .D PHONE($P(SDX,U,1))
43 .S SDY=""
44 .D S3("Pager",PAGER)
45 .D S4("Phone",PHONE)
46 .D STL(SDY)
47 .Q
48 ;PCP
49 S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"PCPR",SDI)) Q:'SDI D
50 .S SDX=$G(^TMP("SDPLIST",$J,DFN,"PCPR",SDI)) Q:'$L(SDX)
51 .S SDY=""
52 .D S1("PC Provider",$P(SDX,U,2))
53 .D S2("Position",$P(SDX,U,4))
54 .D STL(SDY)
55 .D PHONE($P(SDX,U,1))
56 .S SDY=""
57 .D S3("Pager",PAGER)
58 .D S4("Phone",PHONE)
59 .D STL(SDY)
60 .Q
61 ;
62 I $G(SDPRT)="P" D PRT G TDQ
63 S SDII=0
64 F S SDII=$O(^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)) Q:'SDII D
65 .S SDX=^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)
66 .Q:'$D(SDPTA(+$P(SDX,U,11))) S SDIII=0
67 .F S SDIII=$O(^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)) Q:'SDIII D
68 ..S SDZ=^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)
69 ..Q:$P(SDZ,U,3)'=+SDX S SDY=""
70 ..D S1("Non-PC Provider",$P(SDZ,U,2)),S2("Position",$P(SDZ,U,4))
71 ..D STL(SDY) Q
72 .Q
73 S SDI=0
74 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)) Q:'SDI D
75 .S SDX=^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)
76 .S SDTEAM($P(SDX,U,2),+SDX)="",SDPTA=$P(SDX,U,3) Q:'SDPTA D
77 ..S SDII=0
78 ..F S SDII=$O(^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)) Q:'SDII D
79 ...S SDY=^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)
80 ...Q:$P(SDY,U,11)'=SDPTA
81 ...S SDTEAM($P(SDX,U,2),+SDX,$P(SDY,U,2),+SDY)="",SDIII=0
82 ...F S SDIII=$O(^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)) Q:'SDIII D
83 ....S SDZ=^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)
84 ....Q:$P(SDZ,U,3)'=+SDY
85 ....S SDTEAM($P(SDX,U,2),+SDX,$P(SDY,U,2),+SDY,$P(SDZ,U,2),+SDZ)=""
86 ....Q
87 ...Q
88 ..Q
89 .Q
90 S SDTM="" F S SDTM=$O(SDTEAM(SDTM)) Q:SDTM="" D
91 .S SDTMN=0 F S SDTMN=$O(SDTEAM(SDTM,SDTMN)) Q:'SDTMN D
92 ..I SDLN>0 D STL("")
93 ..S SDY="" D S1("Non-PC Team",SDTM)
94 ..S SDPH=$P($G(^SCTM(404.51,+SDTMN,0)),U,2) D:$L(SDPH) S2("Phone",SDPH)
95 ..D STL(SDY) S SDPO=""
96 ..F S SDPO=$O(SDTEAM(SDTM,SDTMN,SDPO)) Q:SDPO="" S SDPON=0 D
97 ...F S SDPON=$O(SDTEAM(SDTM,SDTMN,SDPO,SDPON)) Q:'SDPON D
98 ....I $O(SDTEAM(SDTM,SDTMN,SDPO,SDPON,""))="" S SDY="" D S1("Non-PC Provider",""),S2("Position",SDPO),STL(SDY) Q
99 ....S SDPR=""
100 ....F S SDPR=$O(SDTEAM(SDTM,SDTMN,SDPO,SDPON,SDPR)) Q:SDPR="" D
101 .....S SDPRN=0
102 .....F S SDPRN=$O(SDTEAM(SDTM,SDTMN,SDPO,SDPON,SDPR,SDPRN)) Q:'SDPRN D
103 ......S SDY=""
104 ......D S1("Non-PC Provider",SDPR)
105 ......D S2("Position",SDPO)
106 ......D STL(SDY)
107 ......D PHONE(SDPRN)
108 ......S SDY=""
109 ......D S3("Pager",PAGER)
110 ......D S4("Phone",PHONE)
111 ......D STL(SDY)
112 ......Q
113 .....Q
114 ....Q
115 ...Q
116 ..Q
117 .Q
118 ;
119 I $G(SDPRT)="A" D PRT G TDQ
120 S SDY="",$E(SDY,29)="*** Team Information ***"
121 S ^TMP("SDTEMP",$J,1)=SDY,^TMP("SDTEMP",$J,2)=""
122 I SDLN=2 S SDY="",$E(SDY,20)="-- No team assignment information found --",^TMP("SDTEMP",$J,3)=SDY
123 S GBL=$G(GBL,"") I $L(GBL)<1 S GBL=$S('$D(VALMAR):"^TMP(""SDPP"",$J)",$L(VALMAR)>1:VALMAR,1:"^TMP(""SDPP"",$J)")
124 ;add line at bottom of array for readability
125 S SDI=$O(^TMP("SDTEMP",$J,""),-1)+1,^TMP("SDTEMP",$J,SDI)=""
126 ;respect the array count passed in to the function
127 S (SDII,VALMCNT)=$O(@GBL@(""),-1)+1
128 S SDI=0
129 F S SDI=$O(^TMP("SDTEMP",$J,SDI)) Q:'SDI D
130 .S SDX=^TMP("SDTEMP",$J,SDI),SDII=SDII+1
131 .S @GBL@(SDII,0)=SDX,VALMCNT=$G(VALMCNT)+1
132 .I SDLN<7,SDI>3 S SDII=SDII+1,@GBL@(SDII,0)="",VALMCNT=$G(VALMCNT)+1
133 .Q
134TDQ F SDI="SDPLIST","SDTEMP" K ^TMP(SDI,$J,DFN)
135 Q
136 ;
137S1(SDT,SDX) ;Set first piece of string
138 ;Input: SDT=subtitle
139 ;Input: SDX=data value
140 S SDY=$J(SDT,18)_": "_$E(SDX,1,28) Q
141 ;
142S2(SDT,SDX) ;Set second piece of string
143 ;Input: SDT=subtitle
144 ;Input: SDX=data value
145 I $L($G(SDPRT)),SDCOL>0 Q
146 S $E(SDY,53)=$J(SDT,8)_": "_$E(SDX,1,18) Q
147 ;
148S3(SDT,SDX) ;Set first piece of string that displays phone numbers
149 ;Input: SDT=subtitle
150 ;Input: SDX=data value
151 S SDY=$J(SDT,30)_": "_$E(SDX,1,20)
152 Q
153 ;
154S4(SDT,SDX) ;Set second piece of string that displays phone numbers
155 ;Input: SDT=subtitle
156 ;Input: SDX=data value
157 I $L($G(SDPRT)),SDCOL>0 Q
158 S $E(SDY,56)=$J(SDT,4)_": "_$E(SDX,1,20)
159 Q
160 ;
161PHONE(IEN) ;Get provider's pager and phone numbers.
162 ;Return: PAGER = Pager number
163 ; PHONE = Phone number
164 NEW LIST
165 S (PAGER,PHONE)=""
166 Q:'$G(IEN)
167 Q:'$$NEWPERSN^SCMCGU(IEN,"LIST")
168 S PAGER=$P(LIST(IEN),U,5)
169 S PHONE=$P(LIST(IEN),U,2)
170 Q
171 ;
172STL(SDY) ;Set text line
173 ;Input: SDY=string
174 S SDLN=SDLN+1
175 S ^TMP("SDTEMP",$J,SDLN)=SDY
176 Q
177 ;
178PRT ;Write assignment information
179 N SDI S SDI=0
180 F S SDI=$O(^TMP("SDTEMP",$J,SDI)) Q:'SDI D
181 .W !?(SDCOL),^TMP("SDTEMP",$J,SDI) Q
182 Q
183 ;
184PCLINE(DFN,SDATE) ;PC provider, associate and team in a single line
185 ;Input: DFN=patient ifn
186 ;Input: SDATE=effective date (optional)
187 ;Output: PC provider, associate and team formatted as 80 character
188 ; line, or "" if none
189 ;
190 N SDLIST,SDI,SDX,SDY,SDZ,SDL,SDC,SDTL
191 Q:'DFN "" S:$G(SDATE)<1 SDATE=DT S SDLIST="^TMP(""SDPLIST"",$J)"
192 F SDI="BEGIN","END" S SDATE(SDI)=SDATE
193 S SDATE="SDATE"
194 S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
195 S SDY="PC Prov: ^Assoc. Prov: ^Team: ",SDL=48,SDC=3,SDTL=0
196 S SDX(1)=$$PCL("PCPR")
197 S SDX(2)=$$PCL("PCAP")
198 S SDX(3)=$$PCL("PCTM")
199 K ^TMP("SDPLIST",$J,DFN)
200 F SDI=1,2,3 S SDZ($L(SDX(SDI)),SDI)=""
201 S SDI="" F S SDI=$O(SDZ(SDI)) Q:SDI="" D
202 .S SDII=0 F S SDII=$O(SDZ(SDI,SDII)) Q:'SDII D
203 ..I 'SDI S SDC=SDC-1 Q
204 ..I SDI<(SDL\SDC) S SDX(SDII)=$P(SDY,U,SDII)_SDX(SDII),SDL=SDL-SDI,SDC=SDC-1 Q
205 ..S SDX(SDII)=$P(SDY,U,SDII)_$E(SDX(SDII),1,(SDL\SDC))
206 ..Q
207 .Q
208 F SDI=1,2,3 S SDTL=SDTL+$L(SDX(SDI))
209 Q:SDTL=0 ""
210 S SDX=SDX(1),$E(SDX,($L(SDX)+1+(80-SDTL\2)))=SDX(2),$E(SDX,81-$L(SDX(3)))=SDX(3)
211 Q SDX
212 ;
213PCL(SDSUB) ;Get name value
214 ;Input: SDSUB=node from GETALL^SCAPMCA
215 N SDN
216 S SDN=+$G(^TMP("SDPLIST",$J,DFN,"PCPOS",0))
217 Q:SDN=0 ""
218 Q:SDN>1 "[ambiguous data]"
219 S SDN=+$G(^TMP("SDPLIST",$J,DFN,SDSUB,0))
220 Q:SDN=0 ""
221 Q:SDN>1 "[ambiguous data]"
222 Q $P($G(^TMP("SDPLIST",$J,DFN,SDSUB,1)),U,2)
Note: See TracBrowser for help on using the repository browser.