Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXCPRO

ECXCPRO.m

Go to the documentation of this file. 
  1. ECXCPRO ;ALB/JAP - PRO Extract YTD Report ;11/19/19  13:50
  1.  ;;3.0;DSS EXTRACTS;**21,24,33,84,137,144,177,190**;Dec 22, 1997;Build 36
  1.  ;accumulates extract data by hcpcs code for all extracts in fiscal year date range
  1.  ;if an extract has been purged, then totals will be falsely low
  1.  ;if more than 1 extract exists for a particular month, then totals will be falsely high
  1.  ;if site is multidivisional, then user can generate report for
  1.  ;  any one division - data stored under divisional station# (e.g., 326 or 326AB)
  1.  ;  or for entire facility - data stored under primary station# (e.g., 326) but includes data from all subdivisions
  1.  ;if site is non-divisional, then data stored under facility station#
  1.  ;
  1.  ;
  1. EN ;setup & queue
  1.  N DIC,DA,DR,DIQ,DIR,DIRUT,DTOUT,DUOUT,DIV,LAST,OUT,CNT,ECXPORT ;144
  1.  S ECXERR=0
  1.  S ECXHEAD="PRO"
  1.  W !!,"Setup for PRO Extract YTD HCPCS Report --",!
  1.  ;determine primary division
  1.  W !,"If you belong to more than one Primary Division, you must"
  1.  W !,"select a Primary Division for the report.",!
  1.  S ECXPRIME=$$PDIV^ECXPUTL
  1.  I ECXPRIME=0 D ^ECXKILL Q
  1.  S DA=ECXPRIME,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" D EN^DIQ1
  1.  S ECXPRIME=ECXPRIME_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))
  1.  ;select 1 or more prosthetics divisions for report
  1.  D PRO^ECXDVSN2(DUZ,ECXPRIME,.ECXDIV,.ECXALL,.ECXERR)
  1.  I ECXERR D  Q
  1.  .D ^ECXKILL W !!,?5,"Try again later... exiting.",!
  1.  ;determine fiscal year of report
  1.  S DIR(0)="SMBA^C:CURRENT;P:PREVIOUS",DIR("A")="Select C(urrent) or P(revious) Fiscal Year: ",DIR("B")="CURRENT"
  1.  W ! K X,Y D ^DIR K DIR
  1.  I $D(DUOUT)!($D(DTOUT)) D  Q
  1.  .D ^ECXKILL W !!,?5,"Try again later... exiting.",!
  1.  I Y="C" D
  1.  .S X=$$CYFY^ECXUTL1(DT),ECXARRAY("START")=$P(X,U,3),ECXARRAY("END")=$P(X,U,4)
  1.  I Y="P" D
  1.  .S YR=$E(DT,1,3),MON=$E(DT,4,5) S:+MON<10 YR=YR-1 S X1=YR_"0930"
  1.  .S X=$$CYFY^ECXUTL1(X1),ECXARRAY("START")=$P(X,U,3),ECXARRAY("END")=$P(X,U,4)
  1.  .K C,MON,YR,X1
  1.  ;setup variables for taskmanager
  1.  S ECXPGM="PROCESS^ECXCPRO",ECXDESC="PRO Extract YTD Lab Report"
  1.  S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="",ECXSAVE("ECXPRIME")="",ECXSAVE("ECXALL")=""
  1.  ;determine output device and queue if requested
  1.  S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1  I ECXPORT D  Q  ;144
  1.  .K ^TMP($J,"ECXPORT") ;144
  1.  .S ^TMP($J,"ECXPORT",0)="REPORT TYPE^PSAS HCPCS^QTY COM^TOTAL COM^AVE COM^QTY VA^TOTAL VA^AVE VA^QTY LAB^TOTAL LAB^AVE LAB^ALL AVE^NPPD CODE" ;144,190
  1.  .S CNT=1 ;144
  1.  .D PROCESS ;144
  1.  .D EXPDISP^ECXUTL1 ;144
  1.  .D ^ECXKILL ;144
  1.  W !!,"Please note: The PRO Extract YTD HCPCS Report requires 132 columns."
  1.  W !,"             Select an appropriate device for output."
  1.  W ! D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
  1.  I ECXSAVE("POP")=1 W ! D ^ECXKILL Q
  1.  I ECXSAVE("ZTSK")=0 D
  1.  .K ECXSAVE,ECXPGM,ECXDESC
  1.  .D PROCESS
  1.  ;clean-up and close
  1.  I IO'=IO(0) D ^%ZISC
  1.  D HOME^%ZIS
  1.  Q
  1.  ;
  1. PROCESS ;begin processing
  1.  N DIVISION,E,EXTRACT,REC,NODE0,NODE1,LASTDAY,NODE2 ;177 Added NODE2 to hold new cost values
  1.  K ^TMP($J,"ECXP") S LASTDAY=""
  1.  ;determine which extracts contain data for report
  1.  S (EXTRACT,E)=0
  1.  F  S E=$O(^ECX(727,"E",ECXHEAD,E)) Q:'E  D
  1.  .Q:'$D(^ECX(727,E,0))
  1.  .Q:$P($G(^ECX(727,E,0)),U,4)<ECXARRAY("START")
  1.  .Q:$P($G(^ECX(727,E,0)),U,4)>ECXARRAY("END")
  1.  .Q:$G(^ECX(727,E,"DIV"))'=+ECXPRIME
  1.  .S EXTRACT(E)=^ECX(727,E,0)
  1.  .I $P(EXTRACT(E),U,5)>LASTDAY S LASTDAY=$P(EXTRACT(E),U,5)
  1.  ;setup array of station numbers included in report
  1.  F DIV=0:0 S DIV=$O(ECXDIV(DIV)) Q:'DIV  S ECXSTAT=$P(ECXDIV(DIV),U,2),DIVISION(ECXSTAT)=ECXDIV(DIV)
  1.  ;get the extract data
  1.  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
  1.  .S NODE0=$G(^ECX(727.826,REC,0)),NODE1=$G(^ECX(727.826,REC,1)),NODE2=$G(^ECX(727.826,REC,2)) Q:NODE0=""  ;177 Grab 2 node for new cost info
  1.  .S (ECXCTAMT,ECXLLC,ECXLMC)=0
  1.  .S ECXFELOC=$P(NODE0,U,10),ECXFEKEY=$P(NODE0,U,11)
  1.  .S ECXHCPC=$P(NODE0,U,33),ECXTYPE=$E(ECXFEKEY,6),ECXSRCE=$E(ECXFEKEY,7)
  1.  .S ECXQTY=$P(NODE0,U,12),ECXCTAMT=$P(NODE0,U,25)+$P(NODE2,U,25),ECXGRPR=$P(NODE1,U,4) ;177 Cost for pre FY20 is stored in NODE0, FY20 and later is in NODE2
  1.  .I ECXFELOC["NONL" S ECXSTAT=$P(ECXFELOC,"NONL",1),ECXFORM="NONL"
  1.  .I ECXFELOC["HO2" S ECXSTAT=$P(ECXFELOC,"HO2",1),ECXFORM="NONL" ;137
  1.  .;if this station is lab requesting station, then count lab transaction
  1.  .I ECXFELOC["ORD" D
  1.  ..S ECXSTAT=$P(ECXFELOC,"ORD",1),ECXFORM="ORD"
  1.  ..S ECXLLC=$P(NODE0,U,26)+$P(NODE2,U,26),ECXLMC=$P(NODE0,U,27)+$P(NODE2,U,27) ;177 Pre FY20 costs are stored in NODE0, FY20 and beyond are stored in NODE2
  1.  .;ignore record for receiving station feeder location
  1.  .Q:ECXFELOC["LAB"
  1.  .;ignore record if division not included in this report
  1.  .Q:ECXSTAT=""  Q:'$D(DIVISION(ECXSTAT))
  1.  .;if combining data from all subdivisions, then set in ^tmp using primary station#
  1.  .I ECXALL=1 S ECXSTAT=$P(ECXPRIME,U,2)
  1.  .;be sure there's no padding on cost variables
  1.  .S ECXCTAMT=+$TR(ECXCTAMT," ",0),ECXLLC=+$TR(ECXLLC," ",0),ECXLMC=+$TR(ECXLMC," ",0)
  1.  .;tmp global holds - com qty^com cost^va nonlab qty^va nonlab cost^lab qty^lab labor cost^lab matrl cost
  1.  .I '$D(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC)) S ^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC)="0^0^0^0^0^0^0"
  1.  .I ECXSRCE="C",ECXFORM="NONL" D
  1.  ..S $P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,1)=$P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,1)+ECXQTY
  1.  ..S $P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,2)=$P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,2)+ECXCTAMT
  1.  .I ECXSRCE="V",ECXFORM="NONL" D
  1.  ..S $P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,3)=$P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,3)+ECXQTY
  1.  ..S $P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,4)=$P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,4)+ECXCTAMT
  1.  .I ECXFORM="ORD" D
  1.  ..S $P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,5)=$P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,5)+ECXQTY
  1.  ..S $P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,6)=$P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,6)+ECXLLC
  1.  ..S $P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,7)=$P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,7)+ECXLMC
  1.  .S $P(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC),U,8)=$P(NODE2,U,3) ;190
  1.  ;setup hcpcs descriptions
  1.  D HCPCS
  1.  ;print report
  1.  D PRINT^ECXCPRO1
  1.  ;cleanup
  1.  I '$G(ECXPORT) D AUDIT^ECXKILL ;144
  1.  Q
  1.  ;
  1. HCPCS ;setup hcpcs cross-reference
  1.  N H,HCPCS,CODE,CPTNM,DESC
  1.  S H=0
  1.  F  S H=$O(^RMPR(661.1,H)) Q:+H<1  D
  1.  .;don't skip inactive hcpcs in case doing previous fy
  1.  .S HCPCS="",HCPCS=$P(^RMPR(661.1,H,0),U,1)
  1.  .S CODE=$$CPT^ICPTCOD(HCPCS)
  1.  .I +CODE>0 S CPTNM=$P(CODE,U,2),DESC=$E($P(CODE,U,3),1,26)
  1.  .Q:CPTNM=""
  1.  .S ^TMP($J,"HCPCS",CPTNM)=DESC
  1.  Q