ECXAPRO1 ;ALB/JAP - PRO Extract Audit Report (cont) ;7/17/19 14:44
;;3.0;DSS EXTRACTS;**9,21,132,144,174**;Dec 22, 1997;Build 33
;
DISP ;entry point
N DIC,DA,DR,DIRUT,DTOUT,DUOUT,JJ,SS,LN,PG,QFLG,STN,TYPE
N A1,A2,A3,CA,CB,CC,GCA,GCB,GCC,GRP,GRPHEAD,LINE,LINEP
U IO
S (QFLG,PG)=0,$P(LN,"-",80)=""
F TYPE="N","R","RT" Q:QFLG S STN="",STN=$O(^TMP($J,TYPE,STN)) D ;174
.I '$G(ECXPORT) D HEADER Q:QFLG ;144,174
.D CDATA Q:QFLG
I $G(ECXPORT) Q ;144 Stop processing if exporting
I $E(IOST)'="C" D
.W @IOF S PG=PG+1
.W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
.W !,"DSS Extract Log #: "_ECXEXT
.W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
.W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG
.W !!,LN,!!
.S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ
.W @IOF
I $D(IO(0)) I IO(0)'=IO D ^%ZISC
D HOME^%ZIS
Q
;
CDATA ;accummulate data within each nppd group
S (LINE,LINEP)=""
S (GCA,GCB,GCC)=0
S (CA,CB,CC)=0
I '$D(^TMP($J,TYPE)) D Q
.I $G(ECXPORT) Q ;144 Stop processing if exporting
.W !,?26,"No data available.",!
.Q ;174
F S LINE=$O(^TMP($J,TYPE,STN,LINE)) Q:LINE="" D Q:QFLG
.S GRP=$E(LINE,1,3) D Q:QFLG
..I TYPE="R",GRP["R9" S GRP="R90"
..S GRPHEAD=^TMP($J,"RMPRCODE",GRP)
..I LINEP="" D
...I $G(ECXPORT) Q ;144 Stop processing if exporting
...D:($Y+5>IOSL) HEADER Q:QFLG
...W !,GRPHEAD
.I $E(LINE,0,3)'=$E(LINEP,0,3),LINEP'="" D Q:QFLG
..I $G(ECXPORT) Q ;144 Stop processing if exporting
..D:($Y+5>IOSL) HEADER Q:QFLG
..W !,LN,!
..W ?26,$J(CA,5,0),?34,$J(CB,5,0),?42,$J((CA+CB),5,0),?51,$J(CC,7,0),!
..S (CA,CB,CC)=0
..D:($Y+5>IOSL) HEADER Q:QFLG
..W:LINE'["R99" !,GRPHEAD
.I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG ;144 Don't display if exporting
.I '$G(ECXPORT) W !,LINE,?6,$E($P(^TMP($J,TYPE,STN,LINE),U,15),1,15) ;144 Don't display if exporting
.S A1=+$P(^TMP($J,TYPE,STN,LINE),U,1),A2=+$P(^(LINE),U,2),A3=+$P(^(LINE),U,3)
.I $G(ECXPORT) D Q ;144
..S ^TMP($J,"ECXPORT",CNT)=STN_U_ECXEXT_U_$S(TYPE="N":"NEW",TYPE="R":"REPAIR",1:"RENTAL")_U_GRPHEAD_U_LINE_U_A1_U_A2_U_(A1+A2)_U_$FN(A3,"",0)_U_$S(A2>0:$FN(A3/A2,"",0),1:""),CNT=CNT+1 ;144
..S LINEP=LINE ;144
.W ?26,$J(A1,5,0) S CA=CA+A1,GCA=GCA+A1
.W ?34,$J(A2,5,0) S CB=CB+A2,GCB=GCB+A2
.W ?42,$J(A1+A2,5,0)
.W ?51,$J(A3,7,0) S CC=CC+A3,GCC=GCC+A3
.W:A2>0 ?61,$J(A3/A2,6,0)
.S LINEP=LINE
I $G(ECXPORT) Q ;144 Stop processing if exporting
Q:QFLG
D:($Y+5>IOSL) HEADER Q:QFLG W !,LN,!,?26,$J(CA,5,0),?34,$J(CB,5,0),?42,$J((CA+CB),5,0),?51,$J(CC,7,0),! ;174 print totals for final group
D SUM
Q
;
SUM ;print summary for type
D:($Y+11>IOSL) HEADER Q:QFLG ;174
W:TYPE="N" !!!,"STATION SUMMARY (NEW)"
W:TYPE="R" !!!,"STATION SUMMARY (REPAIR)"
W:TYPE="RT" !!!,"STATION SUMMARY (RENTAL)"
W !,?28,"VA",?36,"Com",?44,"Total",?54,"Cost ($)"
W !,LN
W !,?26,$J(GCA,5,0),?34,$J(GCB,5,0),?42,$J((GCA+GCB),5,0),?51,$J(GCC,7,0)
W !,LN
I TYPE="RT" W !!,"NOTE: For Vista records with Unit of Issue=MO, the extract Unit of Issue",!,"and Quantity have been converted from months to days." ;174
Q
;
I $E(IOST)="C" D
.S SS=20-$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 ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report",?64,"Page "_PG
W !,"DSS Extract Log #: "_ECXEXT
W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
W !,"Station (#): "_$P(ECXDIV,U,2)_" ("_$P(ECXDIV,U,3)_")"
W !,"Report Run Date/Time: "_ECXRUN
W:TYPE="N" !!,"REPORT OF NEW PROSTHETICS ACTIVITIES"
W:TYPE="RT" !!,"REPORT OF RENTAL PROSTHETICS ACTIVITIES"
W:TYPE="R" !!,"REPORT OF REPAIR PROSTHETICS ACTIVITIES"
W !,"Line",?6,"Item",?28,"VA",?36,"Com",?44,"Total",?54,"Cost ($)",?64,"Ave Com ($)"
W !,LN,!
Q
;
CODE ;setup nppd codes
;intended to duplicate code^rmprn63
N NULINE
F I=1:1 S NULINE=$P($T(TEXT+I^ECXAPRO3),";;",2) Q:NULINE["QUIT" D
.I $L($P(NULINE,";",1))>3,STN]"" D
..I $E(NULINE,0,1)'="R" S:$D(^TMP($J,"N",STN,$P(NULINE,";",1))) $P(^TMP($J,"N",STN,$P(NULINE,";",1)),U,15)=$P(NULINE,";",2)
..I $E(NULINE,0,1)="R" S:$D(^TMP($J,"R",STN,$P(NULINE,";",1))) $P(^TMP($J,"R",STN,$P(NULINE,";",1)),U,15)=$P(NULINE,";",2)
.S ^TMP($J,"RMPRCODE",$P(NULINE,";",1))=$P(NULINE,";",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXAPRO1 4418 printed Apr 09, 2024@20:56:44 Page 2
ECXAPRO1 ;ALB/JAP - PRO Extract Audit Report (cont) ;7/17/19 14:44
+1 ;;3.0;DSS EXTRACTS;**9,21,132,144,174**;Dec 22, 1997;Build 33
+2 ;
DISP ;entry point
+1 NEW DIC,DA,DR,DIRUT,DTOUT,DUOUT,JJ,SS,LN,PG,QFLG,STN,TYPE
+2 NEW A1,A2,A3,CA,CB,CC,GCA,GCB,GCC,GRP,GRPHEAD,LINE,LINEP
+3 USE IO
+4 SET (QFLG,PG)=0
SET $PIECE(LN,"-",80)=""
+5 ;174
FOR TYPE="N","R","RT"
if QFLG
QUIT
SET STN=""
SET STN=$ORDER(^TMP($JOB,TYPE,STN))
Begin DoDot:1
+6 ;144,174
IF '$GET(ECXPORT)
DO HEADER
if QFLG
QUIT
+7 DO CDATA
if QFLG
QUIT
End DoDot:1
+8 ;144 Stop processing if exporting
IF $GET(ECXPORT)
QUIT
+9 IF $EXTRACT(IOST)'="C"
Begin DoDot:1
+10 WRITE @IOF
SET PG=PG+1
+11 WRITE !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
+12 WRITE !,"DSS Extract Log #: "_ECXEXT
+13 WRITE !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
+14 WRITE !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG
+15 WRITE !!,LN,!!
+16 SET DIC="^ECX(727.1,"
SET DA=ECXARRAY("DEF")
SET DR="1"
DO EN^DIQ
+17 WRITE @IOF
End DoDot:1
+18 IF $DATA(IO(0))
IF IO(0)'=IO
DO ^%ZISC
+19 DO HOME^%ZIS
+20 QUIT
+21 ;
CDATA ;accummulate data within each nppd group
+1 SET (LINE,LINEP)=""
+2 SET (GCA,GCB,GCC)=0
+3 SET (CA,CB,CC)=0
+4 IF '$DATA(^TMP($JOB,TYPE))
Begin DoDot:1
+5 ;144 Stop processing if exporting
IF $GET(ECXPORT)
QUIT
+6 WRITE !,?26,"No data available.",!
+7 ;174
QUIT
End DoDot:1
QUIT
+8 FOR
SET LINE=$ORDER(^TMP($JOB,TYPE,STN,LINE))
if LINE=""
QUIT
Begin DoDot:1
+9 SET GRP=$EXTRACT(LINE,1,3)
Begin DoDot:2
+10 IF TYPE="R"
IF GRP["R9"
SET GRP="R90"
+11 SET GRPHEAD=^TMP($JOB,"RMPRCODE",GRP)
+12 IF LINEP=""
Begin DoDot:3
+13 ;144 Stop processing if exporting
IF $GET(ECXPORT)
QUIT
+14 if ($Y+5>IOSL)
DO HEADER
if QFLG
QUIT
+15 WRITE !,GRPHEAD
End DoDot:3
End DoDot:2
if QFLG
QUIT
+16 IF $EXTRACT(LINE,0,3)'=$EXTRACT(LINEP,0,3)
IF LINEP'=""
Begin DoDot:2
+17 ;144 Stop processing if exporting
IF $GET(ECXPORT)
QUIT
+18 if ($Y+5>IOSL)
DO HEADER
if QFLG
QUIT
+19 WRITE !,LN,!
+20 WRITE ?26,$JUSTIFY(CA,5,0),?34,$JUSTIFY(CB,5,0),?42,$JUSTIFY((CA+CB),5,0),?51,$JUSTIFY(CC,7,0),!
+21 SET (CA,CB,CC)=0
+22 if ($Y+5>IOSL)
DO HEADER
if QFLG
QUIT
+23 if LINE'["R99"
WRITE !,GRPHEAD
End DoDot:2
if QFLG
QUIT
+24 ;144 Don't display if exporting
IF '$GET(ECXPORT)
if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
+25 ;144 Don't display if exporting
IF '$GET(ECXPORT)
WRITE !,LINE,?6,$EXTRACT($PIECE(^TMP($JOB,TYPE,STN,LINE),U,15),1,15)
+26 SET A1=+$PIECE(^TMP($JOB,TYPE,STN,LINE),U,1)
SET A2=+$PIECE(^(LINE),U,2)
SET A3=+$PIECE(^(LINE),U,3)
+27 ;144
IF $GET(ECXPORT)
Begin DoDot:2
+28 ;144
SET ^TMP($JOB,"ECXPORT",CNT)=STN_U_ECXEXT_U_$SELECT(TYPE="N":"NEW",TYPE="R":"REPAIR",1:"RENTAL")_U_GRPHEAD_U_LINE_U_A1_U_A2_U_(A1+A2)_U_$FNUMBER(A3,"",0)_U_$SELECT(A2>0:$FNUMBER(A3/A2,"",0),1:"")
SET CNT=CNT+1
+29 ;144
SET LINEP=LINE
End DoDot:2
QUIT
+30 WRITE ?26,$JUSTIFY(A1,5,0)
SET CA=CA+A1
SET GCA=GCA+A1
+31 WRITE ?34,$JUSTIFY(A2,5,0)
SET CB=CB+A2
SET GCB=GCB+A2
+32 WRITE ?42,$JUSTIFY(A1+A2,5,0)
+33 WRITE ?51,$JUSTIFY(A3,7,0)
SET CC=CC+A3
SET GCC=GCC+A3
+34 if A2>0
WRITE ?61,$JUSTIFY(A3/A2,6,0)
+35 SET LINEP=LINE
End DoDot:1
if QFLG
QUIT
+36 ;144 Stop processing if exporting
IF $GET(ECXPORT)
QUIT
+37 if QFLG
QUIT
+38 ;174 print totals for final group
if ($Y+5>IOSL)
DO HEADER
if QFLG
QUIT
WRITE !,LN,!,?26,$JUSTIFY(CA,5,0),?34,$JUSTIFY(CB,5,0),?42,$JUSTIFY((CA+CB),5,0),?51,$JUSTIFY(CC,7,0),!
+39 DO SUM
+40 QUIT
+41 ;
SUM ;print summary for type
+1 ;174
if ($Y+11>IOSL)
DO HEADER
if QFLG
QUIT
+2 if TYPE="N"
WRITE !!!,"STATION SUMMARY (NEW)"
+3 if TYPE="R"
WRITE !!!,"STATION SUMMARY (REPAIR)"
+4 if TYPE="RT"
WRITE !!!,"STATION SUMMARY (RENTAL)"
+5 WRITE !,?28,"VA",?36,"Com",?44,"Total",?54,"Cost ($)"
+6 WRITE !,LN
+7 WRITE !,?26,$JUSTIFY(GCA,5,0),?34,$JUSTIFY(GCB,5,0),?42,$JUSTIFY((GCA+GCB),5,0),?51,$JUSTIFY(GCC,7,0)
+8 WRITE !,LN
+9 ;174
IF TYPE="RT"
WRITE !!,"NOTE: For Vista records with Unit of Issue=MO, the extract Unit of Issue",!,"and Quantity have been converted from months to days."
+10 QUIT
+11 ;
+1 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+2 SET SS=20-$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 ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report",?64,"Page "_PG
+7 WRITE !,"DSS Extract Log #: "_ECXEXT
+8 WRITE !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
+9 WRITE !,"Station (#): "_$PIECE(ECXDIV,U,2)_" ("_$PIECE(ECXDIV,U,3)_")"
+10 WRITE !,"Report Run Date/Time: "_ECXRUN
+11 if TYPE="N"
WRITE !!,"REPORT OF NEW PROSTHETICS ACTIVITIES"
+12 if TYPE="RT"
WRITE !!,"REPORT OF RENTAL PROSTHETICS ACTIVITIES"
+13 if TYPE="R"
WRITE !!,"REPORT OF REPAIR PROSTHETICS ACTIVITIES"
+14 WRITE !,"Line",?6,"Item",?28,"VA",?36,"Com",?44,"Total",?54,"Cost ($)",?64,"Ave Com ($)"
+15 WRITE !,LN,!
+16 QUIT
+17 ;
CODE ;setup nppd codes
+1 ;intended to duplicate code^rmprn63
+2 NEW NULINE
+3 FOR I=1:1
SET NULINE=$PIECE($TEXT(TEXT+I^ECXAPRO3),";;",2)
if NULINE["QUIT"
QUIT
Begin DoDot:1
+4 IF $LENGTH($PIECE(NULINE,";",1))>3
IF STN]""
Begin DoDot:2
+5 IF $EXTRACT(NULINE,0,1)'="R"
if $DATA(^TMP($JOB,"N",STN,$PIECE(NULINE,";",1)))
SET $PIECE(^TMP($JOB,"N",STN,$PIECE(NULINE,";",1)),U,15)=$PIECE(NULINE,";",2)
+6 IF $EXTRACT(NULINE,0,1)="R"
if $DATA(^TMP($JOB,"R",STN,$PIECE(NULINE,";",1)))
SET $PIECE(^TMP($JOB,"R",STN,$PIECE(NULINE,";",1)),U,15)=$PIECE(NULINE,";",2)
End DoDot:2
+7 SET ^TMP($JOB,"RMPRCODE",$PIECE(NULINE,";",1))=$PIECE(NULINE,";",2)
End DoDot:1
+8 QUIT
