ECXAECQ ;ALB/JAP - ECQ Extract Audit Report ;3/3/14 14:51
;;3.0;DSS EXTRACTS;**8,33,35,43,44,123,149**;Dec 22, 1997;Build 27
;
EN ;entry point for ECQ extract audit report
N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXQV,ECXPOS,ECXYR,ECXMTH,ECXPFLG,ECXOPT,QFLG,Q2FLG,ECXPORT,RCNT,ECCL ;149
S (ECXERR,QFLG)=0
;ecxaud=0 for 'extract' audit
S ECXHEAD="ECQ",ECXAUD=0
W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
;select extract
D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
Q:ECXERR
;determine if version 3 and using EC National Procedure Codes for current fiscal year
D FILE^DID(509850.6,,"VERSION","ARR","ERR")
S ECXQV=$G(ARR("VERSION"))
S ECXPOS=29
I +ECXQV=3 D
.S ECXYR=$E($P(ECXARRAY("START"),",",2),4,5)
.S ECXMTH=$E(ECXARRAY("START"),1,3)
.I (ECXMTH="OCT")!(ECXMTH="NOV")!(ECXMTH="DEC") S ECXYR=ECXYR+1
.S ECDA=0 F S ECDA=$O(^ACK(509850.8,ECDA)) Q:'ECDA!QFLG S ECDIV=0 F S ECDIV=$O(^ACK(509850.8,ECDA,2,ECDIV)) Q:'ECDIV!QFLG D
..S ECCL=0 F S ECCL=$O(^ACK(509850.8,ECDA,2,ECDIV,2,"B",ECXYR,ECCL)) Q:'ECCL!QFLG D
...S ECXPFLG=$P($G(^ACK(509850.8,ECDA,2,ECDIV,2,ECCL,0)),U,2)
...I ECXPFLG D S QFLG=1
....W !!,"Your site has division(s) which are using EC National Procedure Codes for the",!,"fiscal year covering the time period of this extract."
....W !!,"You have the option to display either EC National Procedure Codes or CPT Codes",!,"for these division(s)."
....F D Q:Q2FLG
.....S Q2FLG=1
.....S DIR(0)="S^1:EC National Procedure Codes;2:CPT Codes",DIR("A")="Selection",DIR("B")=1 D ^DIR K DIR S ECXOPT=Y
.....I X["^" W !!,"This is a required response" S Q2FLG=0
....I ECXOPT=1 S ECXPOS=12
;currently, quasar does not accommodate multi-divisional sites
S ECXALL=0
D ECQ^ECXDVSN1(.ECXDIV,ECXALL,.ECXERR)
I ECXERR=1 D Q
.W !!,?5,"Try again later... exiting.",!
.D AUDIT^ECXKILL
;determine output device and queue if requested
S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added
.K ^TMP($J,"ECXPORT")
.S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^QUASAR SITE^DIVISION^DSS UNIT^PROCEDURE^PROCEDURE DESCRIPTION^VOLUME",RCNT=1
.D PROCESS
.D EXPDISP^ECXUTL1
.D AUDIT^ECXKILL
W !
S ECXPGM="PROCESS^ECXAECQ",ECXDESC="ECQ Extract Audit Report"
S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="",ECXSAVE("ECXPOS")=""
W !
D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
I ECXSAVE("POP")=1 D Q
.W !!,?5,"Try again later... exiting.",!
.D AUDIT^ECXKILL
I ECXSAVE("ZTSK")=0 D
.K ECXSAVE,ECXPGM,ECXDESC
.D PROCESS^ECXAECQ
I IO'=IO(0) D ^%ZISC
D HOME^%ZIS
D AUDIT^ECXKILL
Q
;
PROCESS ;process data in file #727.825
N X,Y,W,ADIV,DATA,DATE,DIV,DIVACK,IEN,LOC,ECNIEN,ECXLINK
N UNIT,UNITN,VOL,PROC,PROCN,SDIV,QQFLG,CNT
K ^TMP($J,"ECXAUD"),^TMP($J,"ECXPROC")
S (CNT,QQFLG)=0,ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
S X=ECXARRAY("START") D ^%DT S ECXSTART=Y,X=ECXARRAY("END")
D ^%DT S ECXEND=Y
;get run date in external format
D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
;get the dss unit links for this division/site
S DIV=0
F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D
.S DIVACK=$P(ECXDIV(DIV),U,1),ECXLINK(DIV)=^ACK(509850.8,DIVACK,"DSS")
;get extract records in date range
S IEN=""
F S IEN=$O(^ECX(727.825,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG
.S DATA=^ECX(727.825,IEN,0),DIV=$P(DATA,U,4),DATE=$P(DATA,U,9)
.S ADIV=$P(^ECX(727.825,IEN,1),U,11) S:ADIV="" ADIV="UNK"
.I +ADIV S X=^DG(40.8,ADIV,0),ADIV=$P(X,U)_" ("_$P(X,U,2)_")"
.;convert free text date to fm internal format date
.S $E(DATE,1,2)=$E(DATE,1,2)-17
.Q:$L(DATE)<7 Q:(DATE<ECXSTART) Q:(DATE>ECXEND)
.;if location is among those selected, then tally event capture data
.I $D(ECXDIV(DIV)) D Q:QQFLG
..;any quasar site that doesn't have links to dss is identified by "xx"
..S UNIT=$P(DATA,U,10)
..S LOC=$S(UNIT=$P(ECXLINK(DIV),U,1):"A",UNIT=$P(ECXLINK(DIV),U,2):"S",1:"XX")
..;any invalid cpt code is identified as "xxxxx"
..S PROC=$E($P(DATA,U,ECXPOS),1,5),VOL=$P(DATA,U,13),PROCN=""
..I ECXPOS=12 D
...S ECNIEN=0,ECNIEN=$O(^EC(725,"D",PROC,ECNIEN)) Q:'ECNIEN
...S PROCN=$P($G(^EC(725,+ECNIEN,0)),U)
..I PROCN="" D
...S ECNIEN=0,ECNIEN=$$CODEN^ICPTCOD(PROC) I +ECNIEN>0 S PROCN=$P($$CPT^ICPTCOD(PROC,DATE),U,3)
..S PROC="A"_PROC S:VOL="" VOL=1
..S:PROCN="" PROCN="Unknown"
..I '$D(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)) S ^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)=0_U_PROCN
..S $P(^(PROC),U,1)=$P(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC),U,1)+VOL,CNT=CNT+1
..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ
;print the report
D PRINT
I $G(ECXPORT) Q ;149 Stop processing if exporting
D AUDIT^ECXKILL
Q
;
PRINT ;print quasar data by site and dss unit order
N JJ,SS,LN,P,LOC,UNITN,PG,QFLG,GTOT,STOT,TOT,PROC,PROCN
N DIR,DIRUT,DIV,DIVNM,DTOUT,DUOUT
U IO
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
S (QFLG,PG)=0,$P(LN,"-",80)="",DIV=""
F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D Q:QFLG
.S DIVNM=$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"
.I '$G(ECXPORT) D HEADER Q:QFLG ;149
.S GTOT=0,STOT("A")=0,STOT("S")=0,STOT("XX")=0
.I '$D(^TMP($J,"ECXAUD",DIV)) D Q
..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_"^"_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_"^No data available for this QUASAR site" Q ;149
..W !!,?5,"No data available for this QUASAR site.",!!
.I $D(^TMP($J,"ECXAUD",DIV)) S ADIV="" D
..F S ADIV=$O(^TMP($J,"ECXAUD",DIV,ADIV)) Q:ADIV="" S LOC="" D Q:QFLG
...F S LOC=$O(^TMP($J,"ECXAUD",DIV,ADIV,LOC)) Q:LOC="" D Q:QFLG
....;write the unit name
....S UNITN=$S(LOC="A":"Audiology",LOC="S":"Speech Pathology",1:"Unknown"),PROC=""
....I '$G(ECXPORT) D:($Y+2>IOSL) HEADER Q:QFLG W !,"Division: ("_ADIV_")",!?20,UNITN ;149
....F S PROC=$O(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)) Q:PROC="" D Q:QFLG
.....S TOT=+^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC),PROCN=$P(^(PROC),U,2),P=$E(PROC,2,99)
.....S SDIV(ADIV,LOC)=$G(SDIV(ADIV,LOC))+TOT
.....S STOT(LOC)=STOT(LOC)+TOT,GTOT=GTOT+TOT
.....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_ADIV_U_UNITN_U_P_U_PROCN_U_TOT,RCNT=RCNT+1 Q ;149
.....D:($Y+3>IOSL) HEADER Q:QFLG W !,?25,P,?35,$E(PROCN,1,30),?68,$$RJ^XLFSTR(TOT,5," ")
....;write the unit subtotal
....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^^^Volume for "_UNITN_"^^"_+$G(SDIV(ADIV,LOC)),RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q ;149
....D:($Y+4>IOSL) HEADER Q:QFLG
....W !,?25,$E(LN,1,54)
....W !,"Volume for "_UNITN_":",?68,$$RJ^XLFSTR(+$G(SDIV(ADIV,LOC)),5," "),!!
.;write the division grandtotal
.I $G(ECXPORT) D Q ;149 section added
..S ^TMP($J,"ECXPORT",RCNT)="^^^^Total Volume for Audiology^^"_STOT("A"),RCNT=RCNT+1
..S ^TMP($J,"ECXPORT",RCNT)="^^^^Total Volume for Speech Pathology^^"_STOT("S"),RCNT=RCNT+1
..S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^^^Grand Total for Site "_DIVNM_"^^"_GTOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1
.D:($Y+5>IOSL) HEADER Q:QFLG
.W !!,"Total Volume for Audiology:",?68,$$RJ^XLFSTR(STOT("A"),5," ")
.W !,"Total Volume for Speech Pathology:",?68,$$RJ^XLFSTR(STOT("S"),5," ")
.W !!,"Grand Total for Site "_DIVNM_":",?68,$$RJ^XLFSTR(GTOT,5," ")
;print the audit descriptive narrative
I $G(ECXPORT) Q ;149
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
I ($E(IOST)="C"),('QFLG) D
.S SS=22-$Y F JJ=1:1:SS W !
.S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
Q
;
N JJ,SS
I ($E(IOST)="C"),('QFLG) D
.S SS=22-$Y F JJ=1:1:SS W !
.I PG>0 S DIR(0)="E" W ! 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"
W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT")
W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
W !,"Report Run Date/Time: "_ECXRUN
W !,"QUASAR Site: "_$P(ECXDIV(DIV),U,2)_"("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG ;149 Added space to line up data with other headers
W !!,"DSS Unit",?25,"Procedure",?68,"Volume"
W !,LN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXAECQ 8558 printed Dec 13, 2024@01:51:55 Page 2
ECXAECQ ;ALB/JAP - ECQ Extract Audit Report ;3/3/14 14:51
+1 ;;3.0;DSS EXTRACTS;**8,33,35,43,44,123,149**;Dec 22, 1997;Build 27
+2 ;
EN ;entry point for ECQ extract audit report
+1 ;149
NEW %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXQV,ECXPOS,ECXYR,ECXMTH,ECXPFLG,ECXOPT,QFLG,Q2FLG,ECXPORT,RCNT,ECCL
+2 SET (ECXERR,QFLG)=0
+3 ;ecxaud=0 for 'extract' audit
+4 SET ECXHEAD="ECQ"
SET ECXAUD=0
+5 WRITE !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
+6 ;select extract
+7 DO AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
+8 if ECXERR
QUIT
+9 ;determine if version 3 and using EC National Procedure Codes for current fiscal year
+10 DO FILE^DID(509850.6,,"VERSION","ARR","ERR")
+11 SET ECXQV=$GET(ARR("VERSION"))
+12 SET ECXPOS=29
+13 IF +ECXQV=3
Begin DoDot:1
+14 SET ECXYR=$EXTRACT($PIECE(ECXARRAY("START"),",",2),4,5)
+15 SET ECXMTH=$EXTRACT(ECXARRAY("START"),1,3)
+16 IF (ECXMTH="OCT")!(ECXMTH="NOV")!(ECXMTH="DEC")
SET ECXYR=ECXYR+1
+17 SET ECDA=0
FOR
SET ECDA=$ORDER(^ACK(509850.8,ECDA))
if 'ECDA!QFLG
QUIT
SET ECDIV=0
FOR
SET ECDIV=$ORDER(^ACK(509850.8,ECDA,2,ECDIV))
if 'ECDIV!QFLG
QUIT
Begin DoDot:2
+18 SET ECCL=0
FOR
SET ECCL=$ORDER(^ACK(509850.8,ECDA,2,ECDIV,2,"B",ECXYR,ECCL))
if 'ECCL!QFLG
QUIT
Begin DoDot:3
+19 SET ECXPFLG=$PIECE($GET(^ACK(509850.8,ECDA,2,ECDIV,2,ECCL,0)),U,2)
+20 IF ECXPFLG
Begin DoDot:4
+21 WRITE !!,"Your site has division(s) which are using EC National Procedure Codes for the",!,"fiscal year covering the time period of this extract."
+22 WRITE !!,"You have the option to display either EC National Procedure Codes or CPT Codes",!,"for these division(s)."
+23 FOR
Begin DoDot:5
+24 SET Q2FLG=1
+25 SET DIR(0)="S^1:EC National Procedure Codes;2:CPT Codes"
SET DIR("A")="Selection"
SET DIR("B")=1
DO ^DIR
KILL DIR
SET ECXOPT=Y
+26 IF X["^"
WRITE !!,"This is a required response"
SET Q2FLG=0
End DoDot:5
if Q2FLG
QUIT
+27 IF ECXOPT=1
SET ECXPOS=12
End DoDot:4
SET QFLG=1
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;currently, quasar does not accommodate multi-divisional sites
+29 SET ECXALL=0
+30 DO ECQ^ECXDVSN1(.ECXDIV,ECXALL,.ECXERR)
+31 IF ECXERR=1
Begin DoDot:1
+32 WRITE !!,?5,"Try again later... exiting.",!
+33 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+34 ;determine output device and queue if requested
+35 ;149 Section added
SET ECXPORT=$$EXPORT^ECXUTL1
if ECXPORT=-1
QUIT
IF $GET(ECXPORT)
Begin DoDot:1
+36 KILL ^TMP($JOB,"ECXPORT")
+37 SET ^TMP($JOB,"ECXPORT",0)="EXTRACT LOG #^QUASAR SITE^DIVISION^DSS UNIT^PROCEDURE^PROCEDURE DESCRIPTION^VOLUME"
SET RCNT=1
+38 DO PROCESS
+39 DO EXPDISP^ECXUTL1
+40 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+41 WRITE !
+42 SET ECXPGM="PROCESS^ECXAECQ"
SET ECXDESC="ECQ Extract Audit Report"
+43 SET ECXSAVE("ECXHEAD")=""
SET ECXSAVE("ECXALL")=""
SET ECXSAVE("ECXDIV(")=""
SET ECXSAVE("ECXARRAY(")=""
SET ECXSAVE("ECXPOS")=""
+44 WRITE !
+45 DO DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
+46 IF ECXSAVE("POP")=1
Begin DoDot:1
+47 WRITE !!,?5,"Try again later... exiting.",!
+48 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+49 IF ECXSAVE("ZTSK")=0
Begin DoDot:1
+50 KILL ECXSAVE,ECXPGM,ECXDESC
+51 DO PROCESS^ECXAECQ
End DoDot:1
+52 IF IO'=IO(0)
DO ^%ZISC
+53 DO HOME^%ZIS
+54 DO AUDIT^ECXKILL
+55 QUIT
+56 ;
PROCESS ;process data in file #727.825
+1 NEW X,Y,W,ADIV,DATA,DATE,DIV,DIVACK,IEN,LOC,ECNIEN,ECXLINK
+2 NEW UNIT,UNITN,VOL,PROC,PROCN,SDIV,QQFLG,CNT
+3 KILL ^TMP($JOB,"ECXAUD"),^TMP($JOB,"ECXPROC")
+4 SET (CNT,QQFLG)=0
SET ECXEXT=ECXARRAY("EXTRACT")
SET ECXDEF=ECXARRAY("DEF")
+5 SET X=ECXARRAY("START")
DO ^%DT
SET ECXSTART=Y
SET X=ECXARRAY("END")
+6 DO ^%DT
SET ECXEND=Y
+7 ;get run date in external format
+8 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET ECXRUN=Y
+9 ;get the dss unit links for this division/site
+10 SET DIV=0
+11 FOR
SET DIV=$ORDER(ECXDIV(DIV))
if DIV=""
QUIT
Begin DoDot:1
+12 SET DIVACK=$PIECE(ECXDIV(DIV),U,1)
SET ECXLINK(DIV)=^ACK(509850.8,DIVACK,"DSS")
End DoDot:1
+13 ;get extract records in date range
+14 SET IEN=""
+15 FOR
SET IEN=$ORDER(^ECX(727.825,"AC",ECXEXT,IEN))
if IEN=""
QUIT
Begin DoDot:1
+16 SET DATA=^ECX(727.825,IEN,0)
SET DIV=$PIECE(DATA,U,4)
SET DATE=$PIECE(DATA,U,9)
+17 SET ADIV=$PIECE(^ECX(727.825,IEN,1),U,11)
if ADIV=""
SET ADIV="UNK"
+18 IF +ADIV
SET X=^DG(40.8,ADIV,0)
SET ADIV=$PIECE(X,U)_" ("_$PIECE(X,U,2)_")"
+19 ;convert free text date to fm internal format date
+20 SET $EXTRACT(DATE,1,2)=$EXTRACT(DATE,1,2)-17
+21 if $LENGTH(DATE)<7
QUIT
if (DATE<ECXSTART)
QUIT
if (DATE>ECXEND)
QUIT
+22 ;if location is among those selected, then tally event capture data
+23 IF $DATA(ECXDIV(DIV))
Begin DoDot:2
+24 ;any quasar site that doesn't have links to dss is identified by "xx"
+25 SET UNIT=$PIECE(DATA,U,10)
+26 SET LOC=$SELECT(UNIT=$PIECE(ECXLINK(DIV),U,1):"A",UNIT=$PIECE(ECXLINK(DIV),U,2):"S",1:"XX")
+27 ;any invalid cpt code is identified as "xxxxx"
+28 SET PROC=$EXTRACT($PIECE(DATA,U,ECXPOS),1,5)
SET VOL=$PIECE(DATA,U,13)
SET PROCN=""
+29 IF ECXPOS=12
Begin DoDot:3
+30 SET ECNIEN=0
SET ECNIEN=$ORDER(^EC(725,"D",PROC,ECNIEN))
if 'ECNIEN
QUIT
+31 SET PROCN=$PIECE($GET(^EC(725,+ECNIEN,0)),U)
End DoDot:3
+32 IF PROCN=""
Begin DoDot:3
+33 SET ECNIEN=0
SET ECNIEN=$$CODEN^ICPTCOD(PROC)
IF +ECNIEN>0
SET PROCN=$PIECE($$CPT^ICPTCOD(PROC,DATE),U,3)
End DoDot:3
+34 SET PROC="A"_PROC
if VOL=""
SET VOL=1
+35 if PROCN=""
SET PROCN="Unknown"
+36 IF '$DATA(^TMP($JOB,"ECXAUD",DIV,ADIV,LOC,PROC))
SET ^TMP($JOB,"ECXAUD",DIV,ADIV,LOC,PROC)=0_U_PROCN
+37 SET $PIECE(^(PROC),U,1)=$PIECE(^TMP($JOB,"ECXAUD",DIV,ADIV,LOC,PROC),U,1)+VOL
SET CNT=CNT+1
+38 IF $DATA(ZTQUEUED)
IF (CNT>499)
IF '(CNT#500)
IF $$S^%ZTLOAD
SET QQFLG=1
SET ZTSTOP=1
KILL ZTREQ
End DoDot:2
if QQFLG
QUIT
End DoDot:1
if QQFLG
QUIT
+39 ;print the report
+40 DO PRINT
+41 ;149 Stop processing if exporting
IF $GET(ECXPORT)
QUIT
+42 DO AUDIT^ECXKILL
+43 QUIT
+44 ;
PRINT ;print quasar data by site and dss unit order
+1 NEW JJ,SS,LN,P,LOC,UNITN,PG,QFLG,GTOT,STOT,TOT,PROC,PROCN
+2 NEW DIR,DIRUT,DIV,DIVNM,DTOUT,DUOUT
+3 USE IO
+4 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
QUIT
+5 SET (QFLG,PG)=0
SET $PIECE(LN,"-",80)=""
SET DIV=""
+6 FOR
SET DIV=$ORDER(ECXDIV(DIV))
if DIV=""
QUIT
Begin DoDot:1
+7 SET DIVNM=$PIECE(ECXDIV(DIV),U,2)_" ("_$PIECE(ECXDIV(DIV),U,3)_")"
+8 ;149
IF '$GET(ECXPORT)
DO HEADER
if QFLG
QUIT
+9 SET GTOT=0
SET STOT("A")=0
SET STOT("S")=0
SET STOT("XX")=0
+10 IF '$DATA(^TMP($JOB,"ECXAUD",DIV))
Begin DoDot:2
+11 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_"^"_$PIECE(ECXDIV(DIV),U,2)_" ("_$PIECE(ECXDIV(DIV),U,3)_")"_"^No data available for this QUASAR site"
QUIT
+12 WRITE !!,?5,"No data available for this QUASAR site.",!!
End DoDot:2
QUIT
+13 IF $DATA(^TMP($JOB,"ECXAUD",DIV))
SET ADIV=""
Begin DoDot:2
+14 FOR
SET ADIV=$ORDER(^TMP($JOB,"ECXAUD",DIV,ADIV))
if ADIV=""
QUIT
SET LOC=""
Begin DoDot:3
+15 FOR
SET LOC=$ORDER(^TMP($JOB,"ECXAUD",DIV,ADIV,LOC))
if LOC=""
QUIT
Begin DoDot:4
+16 ;write the unit name
+17 SET UNITN=$SELECT(LOC="A":"Audiology",LOC="S":"Speech Pathology",1:"Unknown")
SET PROC=""
+18 ;149
IF '$GET(ECXPORT)
if ($Y+2>IOSL)
DO HEADER
if QFLG
QUIT
WRITE !,"Division: ("_ADIV_")",!?20,UNITN
+19 FOR
SET PROC=$ORDER(^TMP($JOB,"ECXAUD",DIV,ADIV,LOC,PROC))
if PROC=""
QUIT
Begin DoDot:5
+20 SET TOT=+^TMP($JOB,"ECXAUD",DIV,ADIV,LOC,PROC)
SET PROCN=$PIECE(^(PROC),U,2)
SET P=$EXTRACT(PROC,2,99)
+21 SET SDIV(ADIV,LOC)=$GET(SDIV(ADIV,LOC))+TOT
+22 SET STOT(LOC)=STOT(LOC)+TOT
SET GTOT=GTOT+TOT
+23 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_$PIECE(ECXDIV(DIV),U,2)_" ("_$PIECE(ECXDIV(DIV),U,3)_")"_U_ADIV_U_UNITN_U_P_U_PROCN_U_TOT
SET RCNT=RCNT+1
QUIT
+24 if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
WRITE !,?25,P,?35,$EXTRACT(PROCN,1,30),?68,$$RJ^XLFSTR(TOT,5," ")
End DoDot:5
if QFLG
QUIT
+25 ;write the unit subtotal
+26 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)="^^^^Volume for "_UNITN_"^^"_+$GET(SDIV(ADIV,LOC))
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
QUIT
+27 if ($Y+4>IOSL)
DO HEADER
if QFLG
QUIT
+28 WRITE !,?25,$EXTRACT(LN,1,54)
+29 WRITE !,"Volume for "_UNITN_":",?68,$$RJ^XLFSTR(+$GET(SDIV(ADIV,LOC)),5," "),!!
End DoDot:4
if QFLG
QUIT
End DoDot:3
if QFLG
QUIT
End DoDot:2
+30 ;write the division grandtotal
+31 ;149 section added
IF $GET(ECXPORT)
Begin DoDot:2
+32 SET ^TMP($JOB,"ECXPORT",RCNT)="^^^^Total Volume for Audiology^^"_STOT("A")
SET RCNT=RCNT+1
+33 SET ^TMP($JOB,"ECXPORT",RCNT)="^^^^Total Volume for Speech Pathology^^"_STOT("S")
SET RCNT=RCNT+1
+34 SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)="^^^^Grand Total for Site "_DIVNM_"^^"_GTOT
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
End DoDot:2
QUIT
+35 if ($Y+5>IOSL)
DO HEADER
if QFLG
QUIT
+36 WRITE !!,"Total Volume for Audiology:",?68,$$RJ^XLFSTR(STOT("A"),5," ")
+37 WRITE !,"Total Volume for Speech Pathology:",?68,$$RJ^XLFSTR(STOT("S"),5," ")
+38 WRITE !!,"Grand Total for Site "_DIVNM_":",?68,$$RJ^XLFSTR(GTOT,5," ")
End DoDot:1
if QFLG
QUIT
+39 ;print the audit descriptive narrative
+40 ;149
IF $GET(ECXPORT)
QUIT
+41 IF $EXTRACT(IOST)'="C"
Begin DoDot:1
+42 WRITE @IOF
SET PG=PG+1
+43 WRITE !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
+44 WRITE !,"DSS Extract Log #: "_ECXEXT
+45 WRITE !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
+46 WRITE !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG
+47 WRITE !!,LN,!!
+48 SET DIC="^ECX(727.1,"
SET DA=ECXARRAY("DEF")
SET DR="1"
DO EN^DIQ
End DoDot:1
+49 IF ($EXTRACT(IOST)="C")
IF ('QFLG)
Begin DoDot:1
+50 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+51 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if 'Y
SET QFLG=1
End DoDot:1
+52 QUIT
+53 ;
+1 NEW JJ,SS
+2 IF ($EXTRACT(IOST)="C")
IF ('QFLG)
Begin DoDot:1
+3 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+4 IF PG>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if 'Y
SET QFLG=1
End DoDot:1
+5 if QFLG
QUIT
+6 if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
SET PG=PG+1
+7 WRITE !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
+8 WRITE !,"DSS Extract Log #: "_ECXARRAY("EXTRACT")
+9 WRITE !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
+10 WRITE !,"Report Run Date/Time: "_ECXRUN
+11 ;149 Added space to line up data with other headers
WRITE !,"QUASAR Site: "_$PIECE(ECXDIV(DIV),U,2)_"("_$PIECE(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG
+12 WRITE !!,"DSS Unit",?25,"Procedure",?68,"Volume"
+13 WRITE !,LN
+14 QUIT
