ECXLPRO ;ALB/JAP - PRO Extract YTD Lab Report ;11/19/19 14:00
;;3.0;DSS EXTRACTS;**21,24,36,84,144,177**;Dec 22, 1997;Build 2
;for data associated with prosthetic items produced by facility laboratory
;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,ECXPORT,CNT
S ECXERR=0
S ECXHEAD="PRO"
W !!,"Setup for PRO Extract YTD Laboratory 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"))
;get all prosthetics divisions for report
S ECXALL=1
D PDIV3^ECXPUTL(DUZ,ECXPRIME,.ECXDIV)
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^ECXLPRO",ECXDESC="PRO Extract YTD HCPCS 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^LOCAL QTY^LOCAL LABOR COST^LOCAL MATERIAL COST^LOCAL AVE COST^ALL OTHER QTY^ALL OTHER LABOR COST^ALL OTHER MATERIAL COST^ALL OTHER AVE COST" ;144
.S CNT=1 ;144
.D PROCESS ;144
.D EXPDISP^ECXUTL1 ;144
.D ^ECXKILL ;144
W !!,"Please note: The PRO Extract YTD Laboratory 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 Node2 will hold new cost data
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 node 2 to get new cost data
.S (ECXCTAMT,ECXLLC,ECXLMC)=0
.S ECXFELOC=$P(NODE0,U,10),ECXFEKEY=$P(NODE0,U,11)
.;ignore any record which isn't for lab receiving station
.Q:ECXFELOC'["LAB"
.S ECXHCPC=$P(NODE0,U,33),ECXTYPE=$E(ECXFEKEY,6),ECXREQ=$P($E(ECXFEKEY,8,99),"REQ",1)
.S ECXQTY=$P(NODE0,U,12),ECXCTAMT=$P(NODE0,U,25)+$P(NODE2,U,25),ECXGRPR=$P(NODE1,U,4) ;177 Pre-FY20 cost data is in NODE0, FY20 and beyond cost data is in NODE2
.S ECXSTAT=$P(ECXFELOC,"LAB",1),ECXFORM="LAB"
.S ECXLLC=$P(NODE0,U,26)+$P(NODE2,U,26),ECXLMC=$P(NODE0,U,27)+$P(NODE2,U,27) ;177 Pre FY20 cost data is in NODE0, FY20 and beyond cost data is in NODE2
.;ignore record if division not included in this report
.Q:ECXSTAT="" Q:'$D(DIVISION(ECXSTAT))
.;set in ^tmp using primary station#; determine if requesting station is same as or part of this station
.S ECXLAB="",ECXSTAT=+ECXSTAT,ECXLAB=$S(ECXREQ'[ECXSTAT:"OTHER",1:"SAME")
.;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 - lab qty^lab labor cost^lab matrl cost
.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"
.S $P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,1)=$P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,1)+ECXQTY
.S $P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,2)=$P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,2)+ECXLLC
.S $P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,3)=$P(^TMP($J,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,3)+ECXLMC
;setup hcpcs descriptions
D HCPCS^ECXCPRO
;print report
D PRINT^ECXLPRO1
;cleanup
I '$G(ECXPORT) D AUDIT^ECXKILL ;144
Q
;
HCPCS ;setup hcpcs cross-reference
N H,CPT,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 CPTNM="",CPT=$P(^RMPR(661.1,H,0),U,4)
.I +CPT>0 S CPTNM=$P(^ICPT(CPT,0),U,1),DESC=$E($P(^ICPT(CPT,0),U,2),1,26)
.Q:CPTNM=""
.S ^TMP($J,"HCPCS",CPTNM)=DESC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXLPRO 5987 printed Apr 09, 2024@20:58:01 Page 2
ECXLPRO ;ALB/JAP - PRO Extract YTD Lab Report ;11/19/19 14:00
+1 ;;3.0;DSS EXTRACTS;**21,24,36,84,144,177**;Dec 22, 1997;Build 2
+2 ;for data associated with prosthetic items produced by facility laboratory
+3 ;accumulates extract data by hcpcs code for all extracts in fiscal year date range
+4 ;if an extract has been purged, then totals will be falsely low
+5 ;if more than 1 extract exists for a particular month, then totals will be falsely high
+6 ;if site is multidivisional, then user can generate report for
+7 ; any one division - data stored under divisional station# (e.g., 326 or 326AB)
+8 ; or for entire facility - data stored under primary station# (e.g., 326) but includes data from all subdivisions
+9 ;if site is non-divisional, then data stored under facility station#
+10 ;
EN ;setup & queue
+1 NEW DIC,DA,DR,DIQ,DIR,DIRUT,DTOUT,DUOUT,DIV,LAST,OUT,ECXPORT,CNT
+2 SET ECXERR=0
+3 SET ECXHEAD="PRO"
+4 WRITE !!,"Setup for PRO Extract YTD Laboratory 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 ;get all prosthetics divisions for report
+13 SET ECXALL=1
+14 DO PDIV3^ECXPUTL(DUZ,ECXPRIME,.ECXDIV)
+15 IF ECXERR
Begin DoDot:1
+16 DO ^ECXKILL
WRITE !!,?5,"Try again later... exiting.",!
End DoDot:1
QUIT
+17 ;determine fiscal year of report
+18 SET DIR(0)="SMBA^C:CURRENT;P:PREVIOUS"
SET DIR("A")="Select C(urrent) or P(revious) Fiscal Year: "
SET DIR("B")="CURRENT"
+19 WRITE !
KILL X,Y
DO ^DIR
KILL DIR
+20 IF $DATA(DUOUT)!($DATA(DTOUT))
Begin DoDot:1
+21 DO ^ECXKILL
WRITE !!,?5,"Try again later... exiting.",!
End DoDot:1
QUIT
+22 IF Y="C"
Begin DoDot:1
+23 SET X=$$CYFY^ECXUTL1(DT)
SET ECXARRAY("START")=$PIECE(X,U,3)
SET ECXARRAY("END")=$PIECE(X,U,4)
End DoDot:1
+24 IF Y="P"
Begin DoDot:1
+25 SET YR=$EXTRACT(DT,1,3)
SET MON=$EXTRACT(DT,4,5)
if +MON<10
SET YR=YR-1
SET X1=YR_"0930"
+26 SET X=$$CYFY^ECXUTL1(X1)
SET ECXARRAY("START")=$PIECE(X,U,3)
SET ECXARRAY("END")=$PIECE(X,U,4)
+27 KILL C,MON,YR,X1
End DoDot:1
+28 ;setup variables for taskmanager
+29 SET ECXPGM="PROCESS^ECXLPRO"
SET ECXDESC="PRO Extract YTD HCPCS Report"
+30 SET ECXSAVE("ECXHEAD")=""
SET ECXSAVE("ECXDIV(")=""
SET ECXSAVE("ECXARRAY(")=""
SET ECXSAVE("ECXPRIME")=""
SET ECXSAVE("ECXALL")=""
+31 ;determine output device and queue if requested
+32 ;144
SET ECXPORT=$$EXPORT^ECXUTL1
if ECXPORT=-1
QUIT
IF ECXPORT
Begin DoDot:1
+33 ;144
KILL ^TMP($JOB,"ECXPORT")
+34 ;144
SET ^TMP($JOB,"ECXPORT",0)="REPORT TYPE^PSAS HCPCS^LOCAL QTY^LOCAL LABOR COST^LOCAL MATERIAL COST^LOCAL AVE COST^ALL OTHER QTY^ALL OTHER LABOR COST^ALL OTHER MATERIAL COST^ALL OTHER AVE COST"
+35 ;144
SET CNT=1
+36 ;144
DO PROCESS
+37 ;144
DO EXPDISP^ECXUTL1
+38 ;144
DO ^ECXKILL
End DoDot:1
QUIT
+39 WRITE !!,"Please note: The PRO Extract YTD Laboratory Report requires 132 columns."
+40 WRITE !," Select an appropriate device for output."
+41 WRITE !
DO DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
+42 IF ECXSAVE("POP")=1
WRITE !
DO ^ECXKILL
QUIT
+43 IF ECXSAVE("ZTSK")=0
Begin DoDot:1
+44 KILL ECXSAVE,ECXPGM,ECXDESC
+45 DO PROCESS
End DoDot:1
+46 ;clean-up and close
+47 IF IO'=IO(0)
DO ^%ZISC
+48 DO HOME^%ZIS
+49 QUIT
+50 ;
PROCESS ;begin processing
+1 ;177 Node2 will hold new cost data
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 node 2 to get new cost data
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 ;ignore any record which isn't for lab receiving station
+20 if ECXFELOC'["LAB"
QUIT
+21 SET ECXHCPC=$PIECE(NODE0,U,33)
SET ECXTYPE=$EXTRACT(ECXFEKEY,6)
SET ECXREQ=$PIECE($EXTRACT(ECXFEKEY,8,99),"REQ",1)
+22 ;177 Pre-FY20 cost data is in NODE0, FY20 and beyond cost data 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)
+23 SET ECXSTAT=$PIECE(ECXFELOC,"LAB",1)
SET ECXFORM="LAB"
+24 ;177 Pre FY20 cost data is in NODE0, FY20 and beyond cost data is in NODE2
SET ECXLLC=$PIECE(NODE0,U,26)+$PIECE(NODE2,U,26)
SET ECXLMC=$PIECE(NODE0,U,27)+$PIECE(NODE2,U,27)
+25 ;ignore record if division not included in this report
+26 if ECXSTAT=""
QUIT
if '$DATA(DIVISION(ECXSTAT))
QUIT
+27 ;set in ^tmp using primary station#; determine if requesting station is same as or part of this station
+28 SET ECXLAB=""
SET ECXSTAT=+ECXSTAT
SET ECXLAB=$SELECT(ECXREQ'[ECXSTAT:"OTHER",1:"SAME")
+29 ;be sure there's no padding on cost variables
+30 SET ECXCTAMT=+$TRANSLATE(ECXCTAMT," ",0)
SET ECXLLC=+$TRANSLATE(ECXLLC," ",0)
SET ECXLMC=+$TRANSLATE(ECXLMC," ",0)
+31 ;tmp global holds - lab qty^lab labor cost^lab matrl cost
+32 IF '$DATA(^TMP($JOB,"ECXP",ECXTYPE,ECXHCPC))
SET ^TMP($JOB,"ECXP",ECXTYPE,ECXHCPC,"SAME")="0^0^0"
SET ^TMP($JOB,"ECXP",ECXTYPE,ECXHCPC,"OTHER")="0^0^0"
+33 SET $PIECE(^TMP($JOB,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,1)=$PIECE(^TMP($JOB,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,1)+ECXQTY
+34 SET $PIECE(^TMP($JOB,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,2)=$PIECE(^TMP($JOB,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,2)+ECXLLC
+35 SET $PIECE(^TMP($JOB,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,3)=$PIECE(^TMP($JOB,"ECXP",ECXTYPE,ECXHCPC,ECXLAB),U,3)+ECXLMC
End DoDot:1
+36 ;setup hcpcs descriptions
+37 DO HCPCS^ECXCPRO
+38 ;print report
+39 DO PRINT^ECXLPRO1
+40 ;cleanup
+41 ;144
IF '$GET(ECXPORT)
DO AUDIT^ECXKILL
+42 QUIT
+43 ;
HCPCS ;setup hcpcs cross-reference
+1 NEW H,CPT,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 CPTNM=""
SET CPT=$PIECE(^RMPR(661.1,H,0),U,4)
+6 IF +CPT>0
SET CPTNM=$PIECE(^ICPT(CPT,0),U,1)
SET DESC=$EXTRACT($PIECE(^ICPT(CPT,0),U,2),1,26)
+7 if CPTNM=""
QUIT
+8 SET ^TMP($JOB,"HCPCS",CPTNM)=DESC
End DoDot:1
+9 QUIT
