source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGSDUTL.m@ 1742

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

initial load of WorldVistAEHR
File size: 9.4 KB
Line 
1DGSDUTL ;ALB/PHH,RMM - DG/SD API UTILITIES ;3/4/2004 10:03
2 ;;5.3;Registration;**568**;AUG 13, 1993
3 ;
4 Q
5PCTEAM(DFN,DATE,ASSTYPE) ; Get Primary Care Team
6 ; DFN - IEN of patient file (#2)
7 ; DATE - Date of interest (Default=DT)
8 ; ASSTYPE - Assignment Type (Default=1 for PC Team)
9 ;
10 N RETVAL,ACTDT,SCTM,SCPTTMA,INACTDT
11 S RETVAL=0
12 Q:'$G(DFN) RETVAL
13 S DATE=$G(DATE,DT),ASSTYPE=$G(ASSTYPE,1)
14 ;
15 ; Returns pointer to file #404.51 if it exists, 0 if not
16 S ACTDT=+$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1)
17 S SCTM=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,0))
18 S SCPTTMA=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,0))
19 S INACTDT=$P($G(^SCPT(404.42,+SCPTTMA,0)),U,9)
20 S RETVAL=$S('INACTDT:+SCTM,(INACTDT'<DATE):+SCTM,1:0)
21 S RETVAL=$S('$G(RETVAL):"",1:RETVAL_U_$P($G(^SCTM(404.51,+RETVAL,0)),U,1))
22 Q RETVAL
23 ;
24PCPRACT(DFN,DATE,PCROLE) ; Get PC Practitioner
25 ; DFN - Pointer to Patient file
26 ; DATE - Date of interest
27 ; PCROLE - Practitioner Position where '1' = PC provider
28 ; '2' = PC attending
29 ; '3' = PC associate provider
30 ; Returned: Pointer to file #200 ^ External value of name
31 ; or, if error or none defined, returns a 0 or null
32 ;
33 N RETVAL,SCOK,SCTP,ACTDT,TPLP,TPDALP,INACTDT,PCAP
34 S RETVAL=0
35 Q:'$G(DFN) RETVAL
36 S DATE=$G(DATE,DT),PCROLE=$G(PCROLE,1)
37 ;
38 ; Returns pointer to file #404.57 if it exists, 0 if not
39 S SCOK=1,SCTP=0
40 S ACTDT=+$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,(DATE+.000001)),-1)
41 F TPLP=0:0 S TPLP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP)) Q:TPLP=""!(SCTP=-1) D
42 .F TPDALP=0:0 S TPDALP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP,TPDALP)) Q:TPDALP="" D Q:SCTP=-1
43 ..S INACTDT=$P($G(^SCPT(404.43,+TPDALP,0)),U,4)
44 ..;
45 ..; Error if it's already an active date
46 ..I 'INACTDT S SCTP=$S(SCTP>0:-1,1:TPLP) Q
47 ..I INACTDT'<DATE S SCTP=$S(SCTP>0:-1,1:TPLP)
48 S RETVAL=+SCTP
49 S RETVAL=$S('$G(RETVAL):"",RETVAL=-1:"",1:RETVAL_U_$P($G(^SCTM(404.57,+RETVAL,0)),U,1))
50 ;
51 S SCTP=+RETVAL,PCAP=+$G(PCROLE,1),PCAP=$S(PCAP=0:1,PCAP>3:1,1:PCAP)
52 S PCROLE=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE)
53 S RETVAL=$S('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP))
54 Q RETVAL
55 ;
56DATE ; Get Begin Date and End Date
57 S:$D(%DT(0)) SDT0=%DT(0) S:$D(SDT00) %DT=SDT00 S POP=0 K BEGDATE,ENDDATE W !!,"**** Date Range Selection ****"
58 W ! S %DT=$S($D(SDT00):SDT00,1:"AE"),%DT("A")=" Beginning DATE : " D ^%DT S:Y<0 POP=1 G:Y<0 EX S (BEGDATE,SDBD)=Y
59 W ! S %DT="AE",%DT("A")=" Ending DATE : " D ^%DT K %DT S:Y<0 POP=1 G:Y<0 EX G:Y<SDBD HELP W ! S (ENDDATE,SDED)=Y
60EX K SDT0,SDT00 Q
61HELP W "??",!?5,"Ending date must not be before beginning date" S:$D(SDT0) %DT(0)=SDT0 G DATE
62 ;
63TDATA(DFN,VALMCNT,SDATE,SDPRT,SDCOL) ;
64 ;Team information - gather, format and optionally print.
65 ;
66 ; Input: DFN=patient ifn
67 ; VALMCNT=variable to return number of lines (pass by reference)
68 ; SDATE=effective date (optional)
69 ; SDPRT=print flag, 'P' for PC info only, 'A' for all (optional)
70 ; SDCOL=column to print in conjunction with SDPRT flag (optional)
71 ;
72 Q:DFN'>0
73 N SDI,SDATE,SDLIST,SDX,SDLN,SDY,SDPH,SDTEAM,SDPTA,SDII,SDIII,SDZ
74 N SDTM,SDTMN,SDPO,SDPON,SDPR,SDPRN,PAGER,PHONE
75 ;
76 F SDI="SDPLIST","SDTEMP" K ^TMP(SDI,$J)
77 S SDCOL=+$G(SDCOL),SDATE=$G(SDATE) S:SDATE<1 SDATE=DT
78 F SDI="BEGIN","END" S SDATE(SDI)=SDATE
79 S SDATE="SDATE",SDLIST="^TMP(""SDPLIST"",$J)",SDLN=2
80 S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
81 ;
82 ;PC Team
83 S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"PCTM",SDI)) Q:'SDI D
84 .S SDX=$G(^TMP("SDPLIST",$J,DFN,"PCTM",SDI)) Q:'$L(SDX)
85 .S SDY="" D S1("Primary Care Team",$P(SDX,U,2))
86 .S SDPH=$P($G(^SCTM(404.51,+SDX,0)),U,2) D:$L(SDPH) S2("Phone",SDPH)
87 .S:$P(SDX,U,3) SDPTA($P(SDX,U,3))=""
88 .D STL(SDY)
89 .Q
90 ;
91 ;PCP
92 S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"PCPR",SDI)) Q:'SDI D
93 .S SDX=$G(^TMP("SDPLIST",$J,DFN,"PCPR",SDI)) Q:'$L(SDX)
94 .S SDY="" D S1("PC Provider",$P(SDX,U,2))
95 .D S2("Position",$P(SDX,U,4)),STL(SDY),PHONE($P(SDX,U,1))
96 .S SDY="" D S3("Pager",PAGER),S4("Phone",PHONE),STL(SDY)
97 .Q
98 ;
99 ;AP
100 S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"PCAP",SDI)) Q:'SDI D
101 .S SDX=$G(^TMP("SDPLIST",$J,DFN,"PCAP",SDI)) Q:'$L(SDX)
102 .S SDY="" D S1("Associate Provider",$P(SDX,U,2)),S2("Position",$P(SDX,U,4)),STL(SDY),PHONE($P(SDX,U,1))
103 .S SDY="" D S3("Pager",PAGER),S4("Phone",PHONE),STL(SDY)
104 .Q
105 ;
106 I $G(SDPRT)="P" D PRT G TDQ
107 S SDII=0 F S SDII=$O(^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)) Q:'SDII D
108 .S SDX=^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)
109 .Q:'$D(SDPTA(+$P(SDX,U,11)))
110 .S SDIII=0 F S SDIII=$O(^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)) Q:'SDIII D
111 ..S SDZ=^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)
112 ..Q:$P(SDZ,U,3)'=+SDX
113 ..S SDY="" D S1("Non-PC Provider",$P(SDZ,U,2)),S2("Position",$P(SDZ,U,4)),STL(SDY)
114 ;
115 S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)) Q:'SDI D
116 .S SDX=^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)
117 .S SDTEAM($P(SDX,U,2),+SDX)="",SDPTA=$P(SDX,U,3) Q:'SDPTA D
118 ..S SDII=0 F S SDII=$O(^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)) Q:'SDII D
119 ...S SDY=^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)
120 ...Q:$P(SDY,U,11)'=SDPTA
121 ...S SDTEAM($P(SDX,U,2),+SDX,$P(SDY,U,2),+SDY)="",SDIII=0
122 ...F S SDIII=$O(^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)) Q:'SDIII D
123 ....S SDZ=^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)
124 ....Q:$P(SDZ,U,3)'=+SDY
125 ....S SDTEAM($P(SDX,U,2),+SDX,$P(SDY,U,2),+SDY,$P(SDZ,U,2),+SDZ)=""
126 ;
127 S SDTM="" F S SDTM=$O(SDTEAM(SDTM)) Q:SDTM="" D
128 .S SDTMN=0 F S SDTMN=$O(SDTEAM(SDTM,SDTMN)) Q:'SDTMN D
129 ..I SDLN>0 D STL("")
130 ..S SDY="" D S1("Non-PC Team",SDTM)
131 ..S SDPH=$P($G(^SCTM(404.51,+SDTMN,0)),U,2) D:$L(SDPH) S2("Phone",SDPH),STL(SDY)
132 ..S SDPO="" F S SDPO=$O(SDTEAM(SDTM,SDTMN,SDPO)) Q:SDPO="" S SDPON=0 D
133 ...F S SDPON=$O(SDTEAM(SDTM,SDTMN,SDPO,SDPON)) Q:'SDPON D
134 ....I $O(SDTEAM(SDTM,SDTMN,SDPO,SDPON,""))="" S SDY="" D S1("Non-PC Provider",""),S2("Position",SDPO),STL(SDY) Q
135 ....S SDPR="" F S SDPR=$O(SDTEAM(SDTM,SDTMN,SDPO,SDPON,SDPR)) Q:SDPR="" D
136 .....S SDPRN=0 F S SDPRN=$O(SDTEAM(SDTM,SDTMN,SDPO,SDPON,SDPR,SDPRN)) Q:'SDPRN D
137 ......S SDY="" D S1("Non-PC Provider",SDPR),S2("Position",SDPO),STL(SDY),PHONE(SDPRN)
138 ......S SDY="" D S3("Pager",PAGER),S4("Phone",PHONE),STL(SDY)
139 ;
140 I $G(SDPRT)="A" D PRT G TDQ
141 S SDY="",$E(SDY,29)="*** Team Information ***"
142 S ^TMP("SDTEMP",$J,1)=SDY,^TMP("SDTEMP",$J,2)=""
143 I SDLN=2 S SDY="",$E(SDY,20)="-- No team assignment information found --",^TMP("SDTEMP",$J,3)=SDY
144 S GBL=$G(GBL,"") I $L(GBL)<1 S GBL=$S('$D(VALMAR):"^TMP(""SDPP"",$J)",$L(VALMAR)>1:VALMAR,1:"^TMP(""SDPP"",$J)")
145 ;add line at bottom of array for readability
146 S SDI=$O(^TMP("SDTEMP",$J,""),-1)+1,^TMP("SDTEMP",$J,SDI)=""
147 ;respect the array count passed in to the function
148 S (SDII,VALMCNT)=$O(@GBL@(""),-1)+1
149 S SDI=0
150 F S SDI=$O(^TMP("SDTEMP",$J,SDI)) Q:'SDI D
151 .S SDX=^TMP("SDTEMP",$J,SDI),SDII=SDII+1
152 .S @GBL@(SDII,0)=SDX,VALMCNT=$G(VALMCNT)+1
153 .I SDLN<7,SDI>3 S SDII=SDII+1,@GBL@(SDII,0)="",VALMCNT=$G(VALMCNT)+1
154 .Q
155TDQ F SDI="SDPLIST","SDTEMP" K ^TMP(SDI,$J,DFN)
156 Q
157 ;
158S1(SDT,SDX) ;Set first piece of string
159 ; Input: SDT=subtitle, SDX=data value
160 S SDY=$J(SDT,18)_": "_$E(SDX,1,28) Q
161 ;
162S2(SDT,SDX) ;Set second piece of string
163 ; Input: SDT=subtitle, SDX=data value
164 I $L($G(SDPRT)),SDCOL>0 Q
165 S $E(SDY,53)=$J(SDT,8)_": "_$E(SDX,1,18) Q
166 ;
167S3(SDT,SDX) ;Set first piece of string that displays phone numbers
168 ; Input: SDT=subtitle, SDX=data value
169 S SDY=$J(SDT,30)_": "_$E(SDX,1,20) Q
170 ;
171S4(SDT,SDX) ;Set second piece of string that displays phone numbers
172 ;Input: SDT=subtitle, SDX=data value
173 I $L($G(SDPRT)),SDCOL>0 Q
174 S $E(SDY,56)=$J(SDT,4)_": "_$E(SDX,1,20) Q
175 ;
176PHONE(IEN) ;Get provider's pager and phone numbers.
177 ;Return: PAGER = Pager number
178 ; PHONE = Phone number
179 NEW LIST
180 S (PAGER,PHONE)=""
181 Q:'$G(IEN)
182 Q:'$$NEWPERSN^SCMCGU(IEN,"LIST")
183 S PAGER=$P(LIST(IEN),U,5),PHONE=$P(LIST(IEN),U,2) Q
184 ;
185STL(SDY) ; Set text line
186 ; Input: SDY=string
187 S SDLN=SDLN+1,^TMP("SDTEMP",$J,SDLN)=SDY Q
188 ;
189PRT ; Write assignment information
190 N SDI S SDI=0
191 F S SDI=$O(^TMP("SDTEMP",$J,SDI)) Q:'SDI D
192 .W !?(SDCOL),^TMP("SDTEMP",$J,SDI) Q
193 Q
194 ;
195PCLINE(DFN,SDATE) ;PC provider, associate and team in a single line
196 ; Input: DFN=patient ifn
197 ; SDATE=effective date (optional)
198 ; Output: PC provider, associate and team formatted as 80 character
199 ; line, or "" if none
200 ;
201 N SDLIST,SDI,SDX,SDY,SDZ,SDL,SDC,SDTL
202 Q:'DFN "" S:$G(SDATE)<1 SDATE=DT S SDLIST="^TMP(""SDPLIST"",$J)"
203 F SDI="BEGIN","END" S SDATE(SDI)=SDATE
204 S SDATE="SDATE",SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
205 S SDY="PC Prov: ^Assoc. Prov: ^Team: ",SDL=48,SDC=3,SDTL=0
206 S SDX(1)=$$PCL("PCPR"),SDX(2)=$$PCL("PCAP"),SDX(3)=$$PCL("PCTM")
207 K ^TMP("SDPLIST",$J,DFN)
208 F SDI=1,2,3 S SDZ($L(SDX(SDI)),SDI)=""
209 S SDI="" F S SDI=$O(SDZ(SDI)) Q:SDI="" D
210 .S SDII=0 F S SDII=$O(SDZ(SDI,SDII)) Q:'SDII D
211 ..I 'SDI S SDC=SDC-1 Q
212 ..I SDI<(SDL\SDC) S SDX(SDII)=$P(SDY,U,SDII)_SDX(SDII),SDL=SDL-SDI,SDC=SDC-1 Q
213 ..S SDX(SDII)=$P(SDY,U,SDII)_$E(SDX(SDII),1,(SDL\SDC))
214 ;
215 F SDI=1,2,3 S SDTL=SDTL+$L(SDX(SDI))
216 Q:SDTL=0 ""
217 S SDX=SDX(1),$E(SDX,($L(SDX)+1+(80-SDTL\2)))=SDX(2),$E(SDX,81-$L(SDX(3)))=SDX(3)
218 Q SDX
219 ;
220PCL(SDSUB) ; Get name value
221 ; Input: SDSUB=node from GETALL^SCAPMCA
222 N SDN S SDN=+$G(^TMP("SDPLIST",$J,DFN,"PCPOS",0))
223 Q:SDN=0 ""
224 Q:SDN>1 "[ambiguous data]"
225 S SDN=+$G(^TMP("SDPLIST",$J,DFN,SDSUB,0))
226 Q:SDN=0 ""
227 Q:SDN>1 "[ambiguous data]"
228 Q $P($G(^TMP("SDPLIST",$J,DFN,SDSUB,1)),U,2)
229 ;
230LAST() ; Output - the latest date, beginning day or -100 days
231 ; the APPOINTMENT STATUS UPDATE LOG was updated
232 N SDI,LAST
233 F SDI=0:1:100 S X1=DT,X2=-SDI D C^%DTC S LAST=$O(^SDD(409.65,"B",X,0)) S LAST1=$P($G(^SDD(409.65,+LAST,0)),U,5) Q:LAST1
234 Q LAST
235 ;
236 ;
237 Q
Note: See TracBrowser for help on using the repository browser.