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