source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPO1.m@ 1747

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1SCRPO1 ;BP-CIOFO/KEITH - Historical Patient Position Assignment Listing ; 20 Aug 99 7:49 AM
2 ;;5.3;Scheduling;**177**;AUG 13, 1993
3 ;
4EN ;Queue report
5 N LIST,SORT,SCSP,RTN,DESC
6 S LIST="DIV,TEAM,POS,PCP,ASPR,CLINIC",SORT="DV,TM,TP,PR,EC,PA"
7 S SCSP="PA",RTN="RUN^SCRPO1"
8 S DESC="Historical Patient Position Assignment Listing"
9 D PROMPT(LIST,SORT,SCSP,RTN,DESC) Q
10 ;
11PROMPT(LIST,SORT,SCSP,SCRTN,SCDESC) ;Prompt for report parameters, queue report
12 ;Input: LIST=comma delimited string of list subscripts to prompt for
13 ;Input: SORT=comma delimited string of sort acronyms to prompt for
14 ;Input: SCSP=acronym of last sort to add if not selected (optional)
15 ;Input: SCRTN=report routine entry point
16 ;Input: SCDESC=tasked job description
17 ;
18 N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
19 S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0
20 D TITL^SCRPW50(SCDESC)
21 D SUBT^SCRPW50("**** Date Range Selection ****")
22 S (SCBDT("B"),SCEDT("B"))="TODAY"
23 G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
24 D SUBT^SCRPW50("**** Report Parameter Selection ****")
25 G:'$$ATYPE^SCRPO(.SC) END
26 G:'$$DSUM^SCRPO(.SC) END
27 F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D Q:SCOUT
28 .S SCOUT='$$LIST^SCRPO(.SC,SCX,1)
29 .Q
30 G:SCOUT END
31 D SUBT^SCRPW50("**** Output sort order (optional) ****")
32 G:'$$SORT^SCRPO(.SC,SORT,SCSP) END
33 S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1))
34 G:'$$PPAR^SCRPO(.SC,1,.SCT) END
35 W !!,"This report requires 132 column output!"
36 W ! N ZTSAVE S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("SC")=""
37 D EN^XUTMDEVQ(SCRTN,SCDESC,.ZTSAVE)
38END K ^TMP("SC",$J) D DISP0^SCRPW23,END^SCRPW50 Q
39 ;
40RUN ;Print report
41 N SCFMT,SCTITL,SCTITL2,SCLINE,SCPAGE,SCOUT,SCFF,SCX,SCFF,SCLINE,SCPAGE
42 N SC1,SC2,SC3,SC4,SC5,SC6,SC7,SCN,SCASP,SCUNP,SCI,SCPNOW
43 S SCFMT=$E(^TMP("SC",$J,"FMT")),(SCFF,SCOUT,SCUNP)=0
44 D BUILD(SCFMT) Q:SCOUT S SCI=0
45 F S SCI=$O(^TMP("SCRPT",$J,0,"UNIQUES",SCI)) Q:'SCI S SCUNP=SCUNP+1
46 D HINI D:$E(IOST)="C" DISP0^SCRPW23
47 S SCTITL(2)=$$HDRX("P") D HDR^SCRPO(.SCTITL,132) Q:SCOUT S SCOUT=$$PPAR^SCRPO(.SC,,.SCTITL)=0
48 Q:SCOUT
49 I '$D(^TMP("SCRPT",$J,0)) D G EXIT
50 .K SCTITL(2) D HDR^SCRPO(.SCTITL,132) Q:SCOUT
51 .S SCX="No patient position assignments found within selected report parameters!"
52 .W !!?(132-$L(SCX)\2),SCX
53 .Q
54 S SCPAGE=1
55 I SCFMT="D" S SCTITL(2)=$$HDRX("D") D HDR^SCRPO(.SCTITL,132),SHDR("D") Q:SCOUT D
56 .S SC1=""
57 .F S SC1=$O(^TMP("SCRPT",$J,1,SC1)) Q:SC1=""!SCOUT D
58 ..S SC2=""
59 ..F S SC2=$O(^TMP("SCRPT",$J,1,SC1,SC2)) Q:SC2=""!SCOUT D
60 ...S SC3=""
61 ...F S SC3=$O(^TMP("SCRPT",$J,1,SC1,SC2,SC3)) Q:SC3=""!SCOUT D
62 ....S SCN=^TMP("SCRPT",$J,1,SC1,SC2,SC3),SC4=""
63 ....F S SC4=$O(^TMP("SCRPT",$J,2,SCN,SC4)) Q:SC4=""!SCOUT D
64 .....S SC5=""
65 .....F S SC5=$O(^TMP("SCRPT",$J,2,SCN,SC4,SC5)) Q:SC5=""!SCOUT D
66 ......S SC6=""
67 ......F S SC6=$O(^TMP("SCRPT",$J,2,SCN,SC4,SC5,SC6)) Q:SC6=""!SCOUT D
68 .......S SC7=""
69 .......F S SC7=$O(^TMP("SCRPT",$J,2,SCN,SC4,SC5,SC6,SC7)) Q:SC7=""!SCOUT D
70 ........S SCX=^TMP("SCRPT",$J,2,SCN,SC4,SC5,SC6,SC7)
71 ........I $Y>(IOSL-9) D FOOT1,HDR^SCRPO(.SCTITL,132),SHDR("D") Q:SCOUT
72 ........S SCY="0^20^27^39^43^57^73^89^94^110^122" W !
73 ........F SCI=1:1:11 W ?($P(SCY,U,SCI)),$P(SCX,U,SCI)
74 .......Q
75 ......Q
76 .....Q
77 ....Q
78 ...Q
79 ..Q
80 .D:'SCOUT FOOT1
81 .Q
82 G:SCOUT EXIT
83 S SCTITL(2)=$$HDRX("S") D HDR^SCRPO(.SCTITL,132),SHDR("S") G:SCOUT EXIT
84 S SCASP=^TMP("SCRPT",$J,0,"ASSIGNMENTS")
85 F SCI="PRIMARY ELIGIBILITY","MEANS TEST CATEGORY","GENDER","AGE GROUP","NATIONAL ENROLLMENT PRIORITY","TEAM","PRIMARY CARE","ASSIGNED PROVIDER","PRECEPTOR PROVIDER","DIVISION" D Q:SCOUT
86 .Q:'$D(^TMP("SCRPT",$J,0,SCI))
87 .D:$Y>(IOSL-9) FOOT2,HDR^SCRPO(.SCTITL,132),SHDR("S") Q:SCOUT
88 .W ! D SLINE("--"_SCI_"--") S SCX=""
89 .F S SCX=$O(^TMP("SCRPT",$J,0,SCI,SCX)) Q:SCX=""!SCOUT D
90 ..S SCY=^TMP("SCRPT",$J,0,SCI,SCX)
91 ..S SCZ=SCY*100/SCASP
92 ..D:$Y>(IOSL-5) HDR^SCRPO(.SCTITL,132),SHDR("S") Q:SCOUT
93 ..D SLINE(SCX,SCY,SCZ)
94 ..Q
95 .Q
96 G:SCOUT EXIT
97 W ! D SLINE("Total assignments that meet the parameters of this report:",SCASP,100)
98 D SLINE("Total unique patients that meet the parameters of this report:",SCUNP,100)
99 D FOOT2
100 ;
101EXIT I $E(IOST)="C",'$G(SCOUT) N DIR S DIR(0)="E" D ^DIR
102 F SCI="SC","SCARR","SCRPT" K ^TMP(SCI,$J)
103 K SC D END^SCRPW50 Q
104 ;
105SLINE(SCX,SCY,SCZ) ;Print summary line
106 ;Input: SCX=element
107 ;Input: SCY=count
108 ;Input: SCZ=percent
109 ;
110 W !,$J($P(SCX,U),70) I $L($G(SCY)) W ?71,$J(SCY,10),?81,$J(SCZ,10,2)
111 Q
112 ;
113SHDR(SCX) ;Print report subheader
114 ;Input: SCX='D' for detail, 'S' for summary
115 Q:SCOUT
116 I SCX="S" D Q
117 .W !!?62,"Category",?76,"Count",?84,"Percent"
118 .W !?30,$E(SCLINE,1,40)," -------- --------"
119 .Q
120 W !?20,"Pat.",?27,"Primary",?38,"MT",?94,"Enrolled",!,"Patient Name"
121 W ?20,"Id.",?27,"Elig.",?38,"Cat",?43,"Team",?57,"Provider"
122 W ?73,"Team Position",?89,"PC?",?94,"Clinic",?110,"Act. Date"
123 W ?122,"Inac. Date",!
124 W "------------------ ----- --------- --- ------------ -------------- -------------- --- -------------- ---------- ----------"
125 Q
126 ;
127HDRX(SCX) ;extra header line
128 ;Input: SCX='P' for parameters, 'D' for detail, 'S' for summary
129 Q:SCX="P" "Selected Report Parameters"
130 Q $S(SCX="D":"Detail",1:"Summary")_" for Patient Position Assignments Effective: "_^TMP("SC",$J,"DTR","PBDT")_" to "_^TMP("SC",$J,"DTR","PEDT")
131 ;
132HINI ;Initialize header variables
133 N Y
134 S SCTITL(1)="<*> HISTORICAL PATIENT POSITION ASSIGNMENT LISTING <*>"
135 S SCLINE="",$P(SCLINE,"-",133)="",SCPAGE=1
136 S Y=$$NOW^XLFDT() X ^DD("DD") S SCPNOW=$P(Y,":",1,2)
137 Q
138 ;
139STOP ;Check for stop task request
140 S:$D(ZTQUEUED) (SCOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
141 ;
142BUILD(SCFMT) ;Build report data
143 ;Input: SCFMT=report format (detail or summary)
144 N SCTM,SCTP
145 ;Build from position list
146 I $O(^TMP("SC",$J,"POS",0)) S SCTP=0 D Q
147 .F S SCTP=$O(^TMP("SC",$J,"POS",SCTP)) Q:'SCTP!SCOUT D
148 ..D CKPOS(SCTP,SCFMT),STOP
149 ..Q
150 .Q
151 ;Build from all positions
152 S SCTP=0 F S SCTP=$O(^SCTM(404.57,SCTP)) Q:'SCTP!SCOUT D
153 .D CKPOS(SCTP,SCFMT),STOP
154 .Q
155 Q
156 ;
157CKPOS(SCTP,SCFMT) ;Check team position
158 ;Input: SCTP=TEAM POSITION ifn
159 ;Input: SCFMT=report format (detail or summary)
160 ;
161 N SCDIV,SCTEAM,SCPOS,SCLINIC,SCTP0,SCX
162 S SCTP0=$G(^SCTM(404.57,+SCTP,0)) Q:'$L(SCTP0)
163 S SCX=$P(SCTP0,U) Q:'$L(SCX)
164 S SCPOS=SCX_U_SCTP
165 S SCTEAM=$P(SCTP0,U,2) Q:'$$TMDV(.SCTEAM,.SCDIV)
166 S SCLINIC=$P(SCTP0,U,9) Q:'$$TPCL(.SCLINIC)
167 D BTPOS(SCTP,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT)
168 Q
169 ;
170TPCL(SCLINIC) ;Get team position associated clinic
171 ;Input: SCLINIC=associated clinic pointer from team position
172 ; (returned as name^ifn, if successful and one exists)
173 ;Output: '1' if success, '0' otherwise
174 ;
175 I $O(^TMP("SC",$J,"CLINIC",0)),'$D(^TMP("SC",$J,"CLINIC",+SCLINIC)) Q 0
176 Q:SCLINIC<1 1
177 S SCLINIC=$P($G(^SC(SCLINIC,0)),U)_U_SCLINIC
178 Q 1
179 ;
180TMDV(SCTEAM,SCDIV) ;Get team and division
181 ;Input: SCTEAM=team ifn (returned as name^ifn, if successful)
182 ;Input: SCDIV=variable to return division as name^ifn
183 ;Output: '1' if success, '0' otherwise
184 N SCTM0,SCX
185 Q:SCTEAM<1 0
186 I $O(^TMP("SC",$J,"TEAM",0)),'$D(^TMP("SC",$J,"TEAM",SCTEAM)) Q 0
187 S SCTM0=$G(^SCTM(404.51,SCTEAM,0)) Q:'$L(SCTM0) 0
188 S SCX=$P(SCTM0,U) Q:'$L(SCX) 0
189 S SCTEAM=SCX_U_SCTEAM
190 S SCDIV=$P(SCTM0,U,7) Q:SCDIV<1 0
191 I $O(^TMP("SC",$J,"DIV",0)),'$D(^TMP("SC",$J,"DIV",SCDIV)) Q 0
192 S SCX=$P($G(^DIC(4,SCDIV,0)),U) Q:'$L(SCX) 0
193 S SCDIV=SCX_U_SCDIV
194 Q 1
195 ;
196BTPOS(SCTP,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT) ;Build list of patients for a position
197 ;Input: SCTP=team position ifn
198 ;Input: SCDIV=division^ifn
199 ;Input: SCTEAM=team^ifn
200 ;Input: SCPOS=team position^ifn
201 ;Input: SCLINIC=associated clinic^ifn (if one exists)
202 ;Input: SCFMT=report format (detail or summary)
203 ;
204 N SCARR,SCDT,SCI,SCPASS
205 S SCARR="^TMP(""SCARR"",$J,1)" K @SCARR
206 M SCDT=^TMP("SC",$J,"DTR") S SCDT="SCDT"
207 S SCI=$$PTTP^SCAPMC(SCTP,.SCDT,SCARR),SCI=0
208 F S SCI=$O(^TMP("SCARR",$J,1,SCI)) Q:'SCI D
209 .S SCPASS=^TMP("SCARR",$J,1,SCI)
210 .D BPTPA^SCRPO2(SCPASS,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT)
211 .Q
212 Q
213 ;
214FOOT1 ;Detail report footer
215 N SCI
216 F SCI=1:1:80 W ! Q:$Y>(IOSL-7)
217 W !,SCLINE
218 W !,"NOTE: More than one provider may be associated with a single patient position assignment. This output returns a separate output"
219 W !?6,"line for each related provider during the date range selected."
220 W !!?6,"'PC?' represents provider type: AP = Associate provider, PCP = Primary Care Provider, NPC = Non-Primary Care Provider."
221 W !,SCLINE
222 Q
223 ;
224FOOT2 ;Summary report footer
225 N SCI
226 F SCI=1:1:80 W ! Q:$Y>(IOSL-7)
227 W !,SCLINE
228 W !,"NOTE: More than one provider may be associated with a single patient position assignment. The sum of assignments related to"
229 W !?6,"providers detailed in this summary is likely to be greater than the actual number of patient position assignments"
230 W !?6,"returned by this report."
231 W !,SCLINE
232 Q
Note: See TracBrowser for help on using the repository browser.