ECXCPRO1 ;ALB/JAP - PRO Extract YTD Report (cont) ;12/4/19 10:02
;;3.0;DSS EXTRACTS;**21,84,132,144,174,177,190**;Dec 22, 1997;Build 36
;
PRINT ;print report
N PG,LN,QFLG,NODE,DESC,AVE,JJ,SS,TOTAL,TOT,TQTY
U IO
S QFLG=0,$P(LN,"-",132)=""
S Y=ECXARRAY("START") D DD^%DT S ECXSTART=Y
S Y=$S(LASTDAY:LASTDAY,ECXARRAY("END")>DT:DT,1:ECXARRAY("END")) D DD^%DT S ECXEND=Y
D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
;if ecxall=0, then only one subdivision of multidivision facility
;if ecxall=1, then either entire facility (i.e., non-divisional), or all subdivisions combined under primary station#
;but it's possible that no extract data was found
S ECXSTAT="",ECXSTAT=$O(^TMP($J,"ECXP",ECXSTAT)) I ECXSTAT="" D Q
.I $G(ECXPORT) Q ;144 Don't display anything if exporting
.I ECXALL=0 S ECXSTAT=$O(DIVISION(""))
.F ECXTYPE="N","X","R" D Q:QFLG
..S PG=0 D HEADER
..W !!,?36,"No extract data available."
..I $E(IOST)="C" D Q:QFLG
...S SS=22-$Y F JJ=1:1:SS W !
...S DIR(0)="E" D ^DIR K DIR S:'Y QFLG=1
F ECXTYPE="N","X","R" D Q:QFLG
.S PG=0 I '$G(ECXPORT) D HEADER ;144 Don't print header if exporting
.S ECXHCPC=""
.I '$D(^TMP($J,"ECXP",ECXSTAT,ECXTYPE)) D Q
..I $G(ECXPORT) Q ;144 Don't display anything if exporting
..W !!,?36,"No extract data available."
..I $E(IOST)="C" D Q:QFLG
...S SS=22-$Y F JJ=1:1:SS W !
...S DIR(0)="E" D ^DIR K DIR S:'Y QFLG=1
.F S ECXHCPC=$O(^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC)) Q:ECXHCPC="" D Q:QFLG
..S DESC=$G(^TMP($J,"HCPCS",ECXHCPC)) S:DESC="" DESC="(Unknown)" S DESC=ECXHCPC_" "_DESC
..S NODE=^TMP($J,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC)
..;node holds - com qty^com cost^va nonlab qty^va nonlab cost^lab qty^lab labor cost^lab matrl cost^nppd code
..F I=1:1:7 S X(I)=+$P(NODE,U,I)
..S X(8)=$P(NODE,U,8) ;190 - Alnum field, can't be forced to number
..S AVE("C")=0,AVE("V")=0,AVE("L")=0,AVE("ALL")=0,TOT("L")=0,TOTAL=0,TQTY=0
..S:X(1)>0 AVE("C")=X(2)/X(1) S:X(3)>0 AVE("V")=X(4)/X(3) S TOT("L")=X(6)+X(7) S:X(5)>0 AVE("L")=TOT("L")/X(5)
..S TQTY=X(1)+X(3)+X(5),TOTAL=X(2)+X(4)+TOT("L")
..S:TQTY>0 AVE("ALL")=TOTAL/TQTY
..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG ;144 Don't display anything if exporting
..I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$S(ECXTYPE="N":"NEW",ECXTYPE="R":"RENTAL",1:"REPAIR") D Q ;144
...S ^TMP($J,"ECXPORT",CNT)=^TMP($J,"ECXPORT",CNT)_U_DESC_U_X(1)_U_X(2)_U_$FN(AVE("C"),"",2)_U_X(3)_U_X(4)_U_$FN(AVE("V"),"",2)_U_X(5)_U_TOT("L")_U_$FN(AVE("L"),"",2)_U_$FN(AVE("ALL"),"",2)_U_X(8) ;144,190
...S CNT=CNT+1 ;144
..W !,DESC,?33,$J(X(1),8,0),?43,$J(X(2),8,0),?53,$J(AVE("C"),8,2),?63,$J(X(3),8,0),?73,$J(X(4),8,0),?83,$J(AVE("V"),8,2),?93,$J(X(5),8,0),?103,$J(TOT("L"),8,0),?113,$J(AVE("L"),8,2),?123,$J(AVE("ALL"),8,2)
.Q:$G(ECXPORT)!(QFLG) ;144,177 Don't continue if exporting or user entered '^'
.I ECXTYPE="R" D ;174 Section added for note to display after rental information
..I $Y+3>IOSL D HEADER ;Print header if not enough room for the note
..W:'QFLG !!,"NOTE: For Vista records with Unit of Issue=MO, the extract Unit of Issue and Quantity have been converted from months to days." ;177
.I 'QFLG,$E(IOST)="C" D
..S SS=22-$Y F JJ=1:1:SS W !
..S DIR(0)="E" D ^DIR K DIR S:'Y QFLG=1
I '$G(ECXPORT) W @IOF ;144 Don't write anything if exporting
Q
;
I $E(IOST)="C" D
.S SS=22-$Y F JJ=1:1:SS W !
.I PG>0 S DIR(0)="E" D ^DIR K DIR S:'Y QFLG=1
Q:QFLG
W:$Y!($E(IOST)="C") @IOF S PG=PG+1
W "Prosthetics (PRO) Extract YTD HCPCS Report",?122,"Page "_PG
W !,"FY Date Range: "_ECXSTART_" to "_ECXEND
I ECXALL=0 W !,"Division: "_$P(DIVISION(ECXSTAT),U,3)_" ("_$P(DIVISION(ECXSTAT),U,2)_")"
I ECXALL=1 W !,"Facility: "_$P(ECXPRIME,U,3)_" ("_$P(ECXPRIME,U,2)_")"
W !,"Run Date/Time: "_ECXRUN
W:ECXTYPE="N" !!,"REPORT OF NEW PROSTHETICS ACTIVITIES (Initial, Replacement, or Spare)"
W:ECXTYPE="R" !!,"REPORT OF RENTAL PROSTHETICS ACTIVITIES"
W:ECXTYPE="X" !!,"REPORT OF REPAIR PROSTHETICS ACTIVITIES"
W !,?36,"Qty.",?44,"Total $",?55,"Ave. $",?67,"Qty.",?74,"Total $",?85,"Ave. $",?97,"Qty.",?104,"Total $",?114,"Ave. $",?125,"Ave. $"
W !,"PSAS HCPCS",?35,"-Comm-",?44,"-Comm-",?55,"-Comm-",?67,"-VA-",?75,"-VA-",?85,"-VA-",?96,"-Lab-",?105,"-Lab-",?114,"-Lab-",?125,"-All-"
W !,LN,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXCPRO1 4327 printed Nov 22, 2024@17:02:30 Page 2
ECXCPRO1 ;ALB/JAP - PRO Extract YTD Report (cont) ;12/4/19 10:02
+1 ;;3.0;DSS EXTRACTS;**21,84,132,144,174,177,190**;Dec 22, 1997;Build 36
+2 ;
PRINT ;print report
+1 NEW PG,LN,QFLG,NODE,DESC,AVE,JJ,SS,TOTAL,TOT,TQTY
+2 USE IO
+3 SET QFLG=0
SET $PIECE(LN,"-",132)=""
+4 SET Y=ECXARRAY("START")
DO DD^%DT
SET ECXSTART=Y
+5 SET Y=$SELECT(LASTDAY:LASTDAY,ECXARRAY("END")>DT:DT,1:ECXARRAY("END"))
DO DD^%DT
SET ECXEND=Y
+6 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET ECXRUN=Y
+7 ;if ecxall=0, then only one subdivision of multidivision facility
+8 ;if ecxall=1, then either entire facility (i.e., non-divisional), or all subdivisions combined under primary station#
+9 ;but it's possible that no extract data was found
+10 SET ECXSTAT=""
SET ECXSTAT=$ORDER(^TMP($JOB,"ECXP",ECXSTAT))
IF ECXSTAT=""
Begin DoDot:1
+11 ;144 Don't display anything if exporting
IF $GET(ECXPORT)
QUIT
+12 IF ECXALL=0
SET ECXSTAT=$ORDER(DIVISION(""))
+13 FOR ECXTYPE="N","X","R"
Begin DoDot:2
+14 SET PG=0
DO HEADER
+15 WRITE !!,?36,"No extract data available."
+16 IF $EXTRACT(IOST)="C"
Begin DoDot:3
+17 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+18 SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET QFLG=1
End DoDot:3
if QFLG
QUIT
End DoDot:2
if QFLG
QUIT
End DoDot:1
QUIT
+19 FOR ECXTYPE="N","X","R"
Begin DoDot:1
+20 ;144 Don't print header if exporting
SET PG=0
IF '$GET(ECXPORT)
DO HEADER
+21 SET ECXHCPC=""
+22 IF '$DATA(^TMP($JOB,"ECXP",ECXSTAT,ECXTYPE))
Begin DoDot:2
+23 ;144 Don't display anything if exporting
IF $GET(ECXPORT)
QUIT
+24 WRITE !!,?36,"No extract data available."
+25 IF $EXTRACT(IOST)="C"
Begin DoDot:3
+26 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+27 SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET QFLG=1
End DoDot:3
if QFLG
QUIT
End DoDot:2
QUIT
+28 FOR
SET ECXHCPC=$ORDER(^TMP($JOB,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC))
if ECXHCPC=""
QUIT
Begin DoDot:2
+29 SET DESC=$GET(^TMP($JOB,"HCPCS",ECXHCPC))
if DESC=""
SET DESC="(Unknown)"
SET DESC=ECXHCPC_" "_DESC
+30 SET NODE=^TMP($JOB,"ECXP",ECXSTAT,ECXTYPE,ECXHCPC)
+31 ;node holds - com qty^com cost^va nonlab qty^va nonlab cost^lab qty^lab labor cost^lab matrl cost^nppd code
+32 FOR I=1:1:7
SET X(I)=+$PIECE(NODE,U,I)
+33 ;190 - Alnum field, can't be forced to number
SET X(8)=$PIECE(NODE,U,8)
+34 SET AVE("C")=0
SET AVE("V")=0
SET AVE("L")=0
SET AVE("ALL")=0
SET TOT("L")=0
SET TOTAL=0
SET TQTY=0
+35 if X(1)>0
SET AVE("C")=X(2)/X(1)
if X(3)>0
SET AVE("V")=X(4)/X(3)
SET TOT("L")=X(6)+X(7)
if X(5)>0
SET AVE("L")=TOT("L")/X(5)
+36 SET TQTY=X(1)+X(3)+X(5)
SET TOTAL=X(2)+X(4)+TOT("L")
+37 if TQTY>0
SET AVE("ALL")=TOTAL/TQTY
+38 ;144 Don't display anything if exporting
IF '$GET(ECXPORT)
if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
+39 ;144
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",CNT)=$SELECT(ECXTYPE="N":"NEW",ECXTYPE="R":"RENTAL",1:"REPAIR")
Begin DoDot:3
+40 ;144,190
SET ^TMP($JOB,"ECXPORT",CNT)=^TMP($JOB,"ECXPORT",CNT)_U_DESC_U_X(1)_U_X(2)_U_$FNUMBER(AVE("C"),"",2)_U_X(3)_U_X(4)_U_$FNUMBER(AVE("V"),"",2)_U_X(5)_U_TOT("L")_U_$FNUMBER(AVE("L"),"",2)_U_$FNUMBER(AVE("ALL"),"",2)_U_X(8)
+41 ;144
SET CNT=CNT+1
End DoDot:3
QUIT
+42 WRITE !,DESC,?33,$JUSTIFY(X(1),8,0),?43,$JUSTIFY(X(2),8,0),?53,$JUSTIFY(AVE("C"),8,2),?63,$JUSTIFY(X(3),8,0),?73,$JUSTIFY(X(4),8,0),?83,$JUSTIFY(AVE("V"),8,2),?93,$JUSTIFY(X(5),8,0),?103,$JUSTIFY(TOT("L"),8,0),?113,...
... $JUSTIFY(AVE("L"),8,2),?123,$JUSTIFY(AVE("ALL"),8,2)
End DoDot:2
if QFLG
QUIT
+43 ;144,177 Don't continue if exporting or user entered '^'
if $GET(ECXPORT)!(QFLG)
QUIT
+44 ;174 Section added for note to display after rental information
IF ECXTYPE="R"
Begin DoDot:2
+45 ;Print header if not enough room for the note
IF $Y+3>IOSL
DO HEADER
+46 ;177
if 'QFLG
WRITE !!,"NOTE: For Vista records with Unit of Issue=MO, the extract Unit of Issue and Quantity have been converted from months to days."
End DoDot:2
+47 IF 'QFLG
IF $EXTRACT(IOST)="C"
Begin DoDot:2
+48 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+49 SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET QFLG=1
End DoDot:2
End DoDot:1
if QFLG
QUIT
+50 ;144 Don't write anything if exporting
IF '$GET(ECXPORT)
WRITE @IOF
+51 QUIT
+52 ;
+1 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+2 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+3 IF PG>0
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET QFLG=1
End DoDot:1
+4 if QFLG
QUIT
+5 if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
SET PG=PG+1
+6 WRITE "Prosthetics (PRO) Extract YTD HCPCS Report",?122,"Page "_PG
+7 WRITE !,"FY Date Range: "_ECXSTART_" to "_ECXEND
+8 IF ECXALL=0
WRITE !,"Division: "_$PIECE(DIVISION(ECXSTAT),U,3)_" ("_$PIECE(DIVISION(ECXSTAT),U,2)_")"
+9 IF ECXALL=1
WRITE !,"Facility: "_$PIECE(ECXPRIME,U,3)_" ("_$PIECE(ECXPRIME,U,2)_")"
+10 WRITE !,"Run Date/Time: "_ECXRUN
+11 if ECXTYPE="N"
WRITE !!,"REPORT OF NEW PROSTHETICS ACTIVITIES (Initial, Replacement, or Spare)"
+12 if ECXTYPE="R"
WRITE !!,"REPORT OF RENTAL PROSTHETICS ACTIVITIES"
+13 if ECXTYPE="X"
WRITE !!,"REPORT OF REPAIR PROSTHETICS ACTIVITIES"
+14 WRITE !,?36,"Qty.",?44,"Total $",?55,"Ave. $",?67,"Qty.",?74,"Total $",?85,"Ave. $",?97,"Qty.",?104,"Total $",?114,"Ave. $",?125,"Ave. $"
+15 WRITE !,"PSAS HCPCS",?35,"-Comm-",?44,"-Comm-",?55,"-Comm-",?67,"-VA-",?75,"-VA-",?85,"-VA-",?96,"-Lab-",?105,"-Lab-",?114,"-Lab-",?125,"-All-"
+16 WRITE !,LN,!
+17 QUIT
