source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXLPRO.m@ 969

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

initial load of FOIAVistA 6/30/08 version
File size: 5.0 KB
Line 
1ECXLPRO ;ALB/JAP - PRO Extract YTD Lab Report ; 8/23/05 1:40pm
2 ;;3.0;DSS EXTRACTS;**21,24,36,84**;Dec 22, 1997
3 ;for data associated with prosthetic items produced by facility laboratory
4 ;accumulates extract data by hcpcs code for all extracts in fiscal year date range
5 ;if an extract has been purged, then totals will be falsely low
6 ;if more than 1 extract exists for a particular month, then totals will be falsely high
7 ;if site is multidivisional, then user can generate report for
8 ; any one division - data stored under divisional station# (e.g., 326 or 326AB)
9 ; or for entire facility - data stored under primary station# (e.g., 326) but includes data from all subdivisions
10 ;if site is non-divisional, then data stored under facility station#
11 ;
12EN ;setup & queue
13 N DIC,DA,DR,DIQ,DIR,DIRUT,DTOUT,DUOUT,DIV,LAST,OUT
14 S ECXERR=0
15 S ECXHEAD="PRO"
16 W !!,"Setup for PRO Extract YTD Laboratory Report --",!
17 ;determine primary division
18 W !,"If you belong to more than one Primary Division, you must"
19 W !,"select a Primary Division for the report.",!
20 S ECXPRIME=$$PDIV^ECXPUTL
21 I ECXPRIME=0 D ^ECXKILL Q
22 S DA=ECXPRIME,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" D EN^DIQ1
23 S ECXPRIME=ECXPRIME_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))
24 ;get all prosthetics divisions for report
25 S ECXALL=1
26 D PDIV3^ECXPUTL(DUZ,ECXPRIME,.ECXDIV)
27 I ECXERR D Q
28 .D ^ECXKILL W !!,?5,"Try again later... exiting.",!
29 ;determine fiscal year of report
30 S DIR(0)="SMBA^C:CURRENT;P:PREVIOUS",DIR("A")="Select C(urrent) or P(revious) Fiscal Year: ",DIR("B")="CURRENT"
31 W ! K X,Y D ^DIR K DIR
32 I $D(DUOUT)!($D(DTOUT)) D Q
33 .D ^ECXKILL W !!,?5,"Try again later... exiting.",!
34 I Y="C" D
35 .S X=$$CYFY^ECXUTL1(DT),ECXARRAY("START")=$P(X,U,3),ECXARRAY("END")=$P(X,U,4)
36 I Y="P" D
37 .S YR=$E(DT,1,3),MON=$E(DT,4,5) S:+MON<10 YR=YR-1 S X1=YR_"0930"
38 .S X=$$CYFY^ECXUTL1(X1),ECXARRAY("START")=$P(X,U,3),ECXARRAY("END")=$P(X,U,4)
39 .K C,MON,YR,X1
40 ;setup variables for taskmanager
41 S ECXPGM="PROCESS^ECXLPRO",ECXDESC="PRO Extract YTD HCPCS Report"
42 S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="",ECXSAVE("ECXPRIME")="",ECXSAVE("ECXALL")=""
43 ;determine output device and queue if requested
44 W !!,"Please note: The PRO Extract YTD Laboratory Report requires 132 columns."
45 W !," Select an appropriate device for output."
46 W ! D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
47 I ECXSAVE("POP")=1 W ! D ^ECXKILL Q
48 I ECXSAVE("ZTSK")=0 D
49 .K ECXSAVE,ECXPGM,ECXDESC
50 .D PROCESS
51 ;clean-up and close
52 I IO'=IO(0) D ^%ZISC
53 D HOME^%ZIS
54 Q
55 ;
56PROCESS ;begin processing
57 N DIVISION,E,EXTRACT,REC,NODE0,NODE1,LASTDAY
58 K ^TMP($J,"ECXP") S LASTDAY=""
59 ;determine which extracts contain data for report
60 S (EXTRACT,E)=0
61 F S E=$O(^ECX(727,"E",ECXHEAD,E)) Q:'E D
62 .Q:'$D(^ECX(727,E,0))
63 .Q:$P($G(^ECX(727,E,0)),U,4)<ECXARRAY("START")
64 .Q:$P($G(^ECX(727,E,0)),U,4)>ECXARRAY("END")
65 .Q:$G(^ECX(727,E,"DIV"))'=+ECXPRIME
66 .S EXTRACT(E)=^ECX(727,E,0)
67 .I $P(EXTRACT(E),U,5)>LASTDAY S LASTDAY=$P(EXTRACT(E),U,5)
68 ;setup array of station numbers included in report
69 F DIV=0:0 S DIV=$O(ECXDIV(DIV)) Q:'DIV S ECXSTAT=$P(ECXDIV(DIV),U,2),DIVISION(ECXSTAT)=ECXDIV(DIV)
70 ;get the extract data
71 S E=0 F S E=$O(EXTRACT(E)) Q:'E S REC=0 I $D(^ECX(727.826,"AC",E)) F S REC=$O(^ECX(727.826,"AC",E,REC)) Q:'REC D
72 .S NODE0=$G(^ECX(727.826,REC,0)),NODE1=$G(^ECX(727.826,REC,1)) Q:NODE0=""
73 .S (ECXCTAMT,ECXLLC,ECXLMC)=0
74 .S ECXFELOC=$P(NODE0,U,10),ECXFEKEY=$P(NODE0,U,11)
75 .;ignore any record which isn't for lab receiving station
76 .Q:ECXFELOC'["LAB"
77 .S ECXHCPC=$P(NODE0,U,33),ECXTYPE=$E(ECXFEKEY,6),ECXREQ=$P($E(ECXFEKEY,8,99),"REQ",1)
78 .S ECXQTY=$P(NODE0,U,12),ECXCTAMT=$P(NODE0,U,25),ECXGRPR=$P(NODE1,U,4)
79 .S ECXSTAT=$P(ECXFELOC,"LAB",1),ECXFORM="LAB"
80 .S ECXLLC=$P(NODE0,U,26),ECXLMC=$P(NODE0,U,27)
81 .;ignore record if division not included in this report
82 .Q:ECXSTAT="" Q:'$D(DIVISION(ECXSTAT))
83 .;set in ^tmp using primary station#; determine if requesting station is same as or part of this station
84 .S ECXLAB="",ECXSTAT=+ECXSTAT,ECXLAB=$S(ECXREQ'[ECXSTAT:"OTHER",1:"SAME")
85 .;be sure there's no padding on cost variables
86 .S ECXCTAMT=+$TR(ECXCTAMT," ",0),ECXLLC=+$TR(ECXLLC," ",0),ECXLMC=+$TR(ECXLMC," ",0)
87 .;tmp global holds - lab qty^lab labor cost^lab matrl cost
88 .I '$D(^TMP($J,"ECXP",ECXTYPE,ECXHCPC)) S ^TMP($J,"ECXP",ECXTYPE,ECXHCPC,"SAME")="0^0^0",^TMP($J,"ECXP",ECXTYPE,ECXHCPC,"OTHER")="0^0^0"
89 .S $P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,1)=$P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,1)+ECXQTY
90 .S $P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,2)=$P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,2)+ECXLLC
91 .S $P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,3)=$P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,3)+ECXLMC
92 ;setup hcpcs descriptions
93 D HCPCS^ECXCPRO
94 ;print report
95 D PRINT^ECXLPRO1
96 ;cleanup
97 D AUDIT^ECXKILL
98 Q
99 ;
100HCPCS ;setup hcpcs cross-reference
101 N H,CPT,CPTNM,DESC
102 S H=0
103 F S H=$O(^RMPR(661.1,H)) Q:+H<1 D
104 .;don't skip inactive hcpcs in case doing previous fy
105 .S CPTNM="",CPT=$P(^RMPR(661.1,H,0),U,4)
106 .I +CPT>0 S CPTNM=$P(^ICPT(CPT,0),U,1),DESC=$E($P(^ICPT(CPT,0),U,2),1,26)
107 .Q:CPTNM=""
108 .S ^TMP($J,"HCPCS",CPTNM)=DESC
109 Q
Note: See TracBrowser for help on using the repository browser.