ECOSSUM.m

ECOSSUM ;BIR/DMA,RHK,JPW - Ordering Section Summary ;11/18/14  16:03

 ;;2.0;EVENT CAPTURE;**5,8,18,47,72,95,119,126**;8 May 96;Build 8

EN ;entry point from menu option

 W !

 K DIC S DIC=723,DIC(0)="AQEMZ",DIC("A")="Select Ordering Section: " D ^DIC K DIC

 I Y<0 G EXIT

 S ECOS=+Y,ECOSN=$P(Y,"^",2)

 D RANGE

 I '$G(ECLOOP)!'$G(ECSD)!'$G(ECED) G EXIT

 W !

 S JJ=$$ASKLOC^ECRUTL

 I 'JJ G EXIT

 W !

 S JJ=$$ASKDSS^ECRUTL

 I 'JJ G EXIT

 W !

 D DEVICE

 I POP G EXIT

 I $G(ZTSK) G EXIT

 I $G(IO("Q")),'$G(ZTSK) G EXIT

 D START

 D HOME^%ZIS

 G EXIT

 Q

 ;

START ;queued entry point or continuation

 D PROCESS

 I $G(ECPTYP)="E" D EXPORT,EXIT Q  ;119

 U IO D PRINT

 I $D(ECGUI) D EXIT Q

 I IO'=IO(0) D ^%ZISC

 I $D(ZTQUEUED) S ZTREQ="@" D EXIT

 Q

 ;

RANGE ;get any date range

 N ECSTDT,ECENDDT

 W !!,?5,"Enter a Begin Date and End Date for the Event Capture "

 W !,?5,"Ordering Section report.",!

 S (ECSD,ECED)=0

 F  D  Q:ECSD>0  Q:'$G(ECLOOP)

 .S ECLOOP=$$STDT^ECRUTL() I 'ECLOOP Q

 .S ECSD=ECSTDT

 Q:'$G(ECLOOP)!'$G(ECSD)

 F  D  Q:ECED>0  Q:'$G(ECLOOP)

 .S ECLOOP=$$ENDDT^ECRUTL(ECSTDT) I 'ECLOOP Q

 .S ECED=ECENDDT

 .I ECED>(DT+1) D

 ..W !!,?15,"The End Date for this report may not be"

 ..W !,?15,"a future date.  Try again...",!

 ..S ECED=0

 Q 

 ;

DEVICE ;select output device

 W !,"This report is formatted for 132 column output.",!

 K IOP S %ZIS="QM" D ^%ZIS

 I POP W !!,"No device selected.  Exiting...",!! S DIR(0)="E" W ! D ^DIR K DIR Q

 I $D(IO("Q")) D

 .S ZTRTN="START^ECOSSUM",ZTDESC="EC Ordering Section Summary"

 .S ZTSAVE("ECSD")="",ZTSAVE("ECED")="",ZTSAVE("ECOS")="",ZTSAVE("ECOSN")=""

 .S ZTSAVE("ECLOC(")="",ZTSAVE("ECDSSU(")=""

 .D ^%ZTLOAD

 .I '$G(ZTSK) W !,"Report canceled..." S DIR(0)="E" W ! D ^DIR K DIR Q

 .W !,"Report queued as Task #: ",ZTSK S DIR(0)="E" W ! D ^DIR K DIR

 Q

 ;

PROCESS ;get data to print

 N EC,ECD,ECDA,ECPA,ECPATN,ECSS,ECSSN,ECP,ECPN,ECLOCA,ECUNIT,ECCAT,ECFILE,ECPSY,ECPSYN,ECPRV,ECPRVN,EC725,ECLOCN,ECUNITN,ECEPN,ECEPC ;119

 N NLOC,NUNIT,JJ,ECPXD

 K ^TMP("ECOS",$J)

 ;put locations and units into ien subscripted arrays

 S JJ="" F  S JJ=$O(ECLOC(JJ)) Q:JJ=""  D

 .S NLOC($P(ECLOC(JJ),"^",1))=$P(ECLOC(JJ),"^",2)

 S JJ="" F  S JJ=$O(ECDSSU(JJ)) Q:JJ=""  D

 .S NUNIT($P(ECDSSU(JJ),"^",1))=$P(ECDSSU(JJ),"^",2)

 S ECD=ECSD

 F  S ECD=$O(^ECH("AC",ECD)) Q:'ECD  Q:ECD>ECED  D

 .S ECDA="" F  S ECDA=$O(^ECH("AC",ECD,ECDA)) Q:'ECDA  S EC=$G(^ECH(ECDA,0)) I $P(EC,"^",12)=ECOS D

 ..I $P(EC,"^",3)<ECSD!($P(EC,"^",3)>ECED) Q  ;file or x-ref problem

 ..S ECLOCA=+$P(EC,U,4),ECUNIT=+$P(EC,U,7)

 ..I '$D(NLOC(ECLOCA))!('$D(NUNIT(ECUNIT))) Q

 ..S ECLOCN=$G(NLOC(ECLOCA)),ECUNITN=$G(NUNIT(ECUNIT)) ;119 Get location and unit names

 ..S ECP=$P(EC,U,9) Q:ECP']""

 ..S ECCAT=+$P(EC,U,8)

 ..S ECPSY=+$O(^ECJ("AP",ECLOCA,ECUNIT,ECCAT,ECP,""))

 ..S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2)

 ..S ECFILE=$P(ECP,";",2),ECFILE=$S($E(ECFILE)="I":81,$E(ECFILE)="E":725,1:"UNKNOWN")

 ..I ECFILE="UNKNOWN" S (ECPN,ECEPN)="UNKNOWN" ;119

 ..S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0)),"^",5)),ECPXD="",ECEPC="" ;119

 ..I ECCPT'="" D

 ...S ECPXD=$$CPT^ICPTCOD(ECCPT,$P(EC,"^",3)),ECCPT=$P(ECPXD,"^",2)

 ..I ECFILE=81 S (ECPN,ECEPN)=$S($P(ECPXD,"^",3)]"":$P(ECPXD,"^",3),1:"UNKNOWN") ;119

 ..I ECFILE=725 D

 ...S EC725=$G(^EC(725,+ECP,0)),ECPN=$P(EC725,"^",2)_" "_$P(EC725,"^"),ECEPN=$P(EC725,U),ECEPC=$P(EC725,U,2) ;119

 ..S ECPN=ECPN_"~"_ECCPT ;119,126

 ..;ALB/JAM - Get Procedure CPT modifiers

 ..S ECMODF=0 I $O(^ECH(ECDA,"MOD",0))'="" D

 ...K ECMOD S ECMODF=$$MOD^ECUTL(ECDA,"E",.ECMOD)

 ..S (ECPA,ECPATN,ECSS)="",ECPA=$G(^DPT(+$P(EC,"^",2),0)) Q:ECPA=""

 ..S ECPATN=$P(ECPA,"^",1),ECSS=$P(ECPA,"^",9)

 ..S:+ECSS ECSSN=$E(ECSS,6,10) S:ECSS="" ECSSN="UNKN"

 ..S:ECPATN="" ECPATN="UNKNOWN" S ECPATN=ECPATN_"^"_ECSSN

 ..S ECV=+$P(EC,"^",10)

 ..K ECPRV S ECPRV=$$GETPRV^ECPRVMUT(ECDA,.ECPRV) I 'ECPRV D  K ECPRV

 ...M ^TMP("ECOS",$J,$S($G(ECPTYP)="E":ECLOCN,1:ECLOCA),$S($G(ECPTYP)="E":ECUNITN,1:ECUNIT),ECPATN,ECDA,"PRV")=ECPRV ;119 Use names rather than numbers if exporting

 ..I $G(ECPTYP)'="E" S ^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA)=ECSSN_"^"_ECPN_"^"_ECPSYN_"^"_ECV ;119,126

 ..S:$G(ECPTYP)="E" ^TMP("ECOS",$J,ECLOCN,ECUNITN,ECPATN,ECDA)=ECSSN_U_ECCPT_U_ECEPC_U_ECEPN_U_ECPSYN_U_ECV ;119,126

 ..I ECMODF D

 ...M ^TMP("ECOS",$J,$S($G(ECPTYP)="E":ECLOCN,1:ECLOCA),$S($G(ECPTYP)="E":ECUNITN,1:ECUNIT),ECPATN,ECDA,"MOD")=ECMOD ;119 use names rather than numbers when exporting

 Q

 ;

PRINT ;output report

 N ECDA,ECLOCA,ECUNIT,ECPATN,ECSSN,ECPN,ECV,ECPSYN ;126

 N PAGE,QFLAG,DASH,DASH2,PRNTDT,JJ,SS,ALOC,AUNIT,LOC,UNNAME,UNIT,DATA,PTNAME,PROV,PROVN,V,X,Y

 S (PAGE,QFLAG)=0 S $P(DASH,"-",130)="",$P(DASH2,"-",64)=""

 S Y=$P(ECSD,".",1)+1 D DD^%DT S ECSD=Y S Y=$P(ECED,".",1) D DD^%DT S ECED=Y

 D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S PRNTDT=Y

 S ECV("L")=0,ECV("O")=0,ECV("P")=0,ECV("U")=0

 ;if no data exists then print the header and quit

 I '$D(^TMP("ECOS",$J)) D  Q

 .S LOC="" D HEAD

 .W !!,?26,"No data for this Ordering Section for the date range specified.",!!

 .I $E(IOST)="C"&('QFLAG) S DIR(0)="E" D  D ^DIR K DIR

 ..S SS=22-$Y F JJ=1:1:SS W !

 .W:$E(IOST)'="C" @IOF

 ;if there's data in ^TMP then need to present the data alphabetically;

 ;put locations and units in alpha ordered array

 S JJ="" F  S JJ=$O(ECLOC(JJ)) Q:JJ=""  D

 .S ALOC($P(ECLOC(JJ),"^",2))=$P(ECLOC(JJ),"^",1)

 S JJ="" F  S JJ=$O(ECDSSU(JJ)) Q:JJ=""  D

 .S AUNIT($P(ECDSSU(JJ),"^",2))=$P(ECDSSU(JJ),"^",1)

 ;process the ^TMP global data in alpha order for location and unit

 S LOC="" F  S LOC=$O(ALOC(LOC)) Q:LOC=""  S ECLOCA=ALOC(LOC),ECV("L")=0 D  Q:QFLAG

 .D HEAD Q:QFLAG  ;always start a new location at top of page

 .S UNIT="" F  S UNIT=$O(AUNIT(UNIT)) Q:UNIT=""  S ECUNIT=AUNIT(UNIT),ECV("U")=0 D  Q:QFLAG

 ..I '$D(^TMP("ECOS",$J,ECLOCA,ECUNIT)) Q

 ..S UNNAME=$E(UNIT,1,20)

 ..D:($Y+6>IOSL) HEAD Q:QFLAG  W !,UNNAME ;126 Removed excess linefeed

 ..S ECPATN="" F  S ECPATN=$O(^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN)) Q:ECPATN=""  S ECV("P")=0 D  Q:QFLAG

 ...S PTNAME=$P(ECPATN,"^",1),PTNAME=$E(PTNAME,1,22),ECSSN=$P(ECPATN,"^",2)

 ...W ?24,PTNAME,?48,ECSSN

 ...S ECDA="" F  S ECDA=$O(^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA)) Q:ECDA=""  S DATA=^(ECDA) D  Q:QFLAG

 ....S ECPN=$P(DATA,"^",2),ECPN=$S($P(ECPN,"~",2)'="":$J($P(ECPN,"~",2)_" ",6),1:"")_$P(ECPN,"~") ;126

 ....S ECV=$P(DATA,"^",4),ECV=ECV\1,ECPSYN=$P(DATA,U,3) D  ;126

 .....F V="L","O","P","U" S ECV(V)=ECV(V)+ECV

 .....S:+ECV>9999 ECV="9999+" S ECV=$$RJ^XLFSTR(ECV,5," ") ;unusually high individual volume figure

 ....K PROV M PROV=^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA,"PRV")

 ....K ECMOD M ECMOD=^TMP("ECOS",$J,ECLOCA,ECUNIT,ECPATN,ECDA,"MOD")

 ....W ?54,ECPN,?112,ECV,!,?25,$P($G(PROV(1)),"^",2),?60,ECPSYN K PROV(1) ;126

 ....D:($Y+6>IOSL) HEAD Q:QFLAG

 ....;ALB/JAM - write cpt procedure modifiers on same line with providers

 ....S MOD=0,PROVN=1 F  S MOD=$O(ECMOD(MOD)),PROVN=$O(PROV(PROVN)) Q:(MOD="")&(PROVN="")  D  I QFLAG Q

 .....I ($Y+6>IOSL) D HEAD Q:QFLAG  W !?54,ECPN

 .....W !

 .....I PROVN'="" W ?25,$P($G(PROV(PROVN)),"^",2) K PROV(PROVN) ;126

 .....I MOD'="" W ?60,"- ",MOD," ",$P(ECMOD(MOD),U,3) K ECMOD(MOD) ;126

 ....W ! ;start a new line

 ...;write subtotal for patient

 ...Q:QFLAG  D:($Y+6>IOSL) HEAD Q:QFLAG

 ...W ?54,DASH2,!

 ...W ?24,"Subtotal for "_$P(ECPATN,"^",1)_":",?112,$$RJ^XLFSTR(ECV("P"),5," "),!! ;126

 ..;write total for unit

 ..Q:QFLAG  D:($Y+6>IOSL) HEAD Q:QFLAG

 ..W !,"Subtotal for DSS Unit "_UNIT_":",?111,$$RJ^XLFSTR(ECV("U"),6," "),! ;126

 .;write the total for the location

 .Q:QFLAG  D:($Y+6>IOSL) HEAD Q:QFLAG

 .W !!,"Total for Location "_LOC_":",?111,$$RJ^XLFSTR(ECV("L"),6," "),! ;126

 ;write the ordering section grandtotal

 Q:QFLAG  D:($Y+8>IOSL) HEAD Q:QFLAG

 W !!!,"Grand Total for Ordering Section "_ECOSN_":",?111,$$RJ^XLFSTR(ECV("O"),6," "),! ;126

 ;all done

 D FOOTER  ;print footer on last page

 I $E(IOST)="C"&('QFLAG) S DIR(0)="E" D  D ^DIR W @IOF

 .S SS=22-$Y F JJ=1:1:SS W !

 W:$E(IOST)'="C" @IOF

 Q

HEAD ;header

 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !

 I PAGE>0 D FOOTER

 I $E(IOST)="C",PAGE>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLAG=1 Q

 W:$Y!($E(IOST)="C") @IOF

 S PAGE=PAGE+1

 W !,?26,"Event Capture Ordering Section Summary for ",ECOSN,?105,"Page: ",PAGE

 W !,?26,"for the Date Range ",$$FMTE^XLFDT(ECSD)," to ",$$FMTE^XLFDT(ECED),?102,"Printed: "_PRNTDT

 W !,?26,"Location: ",LOC,!

 W !,"DSS Unit",?24,"Patient",?48,"SSN",?54,"Procedure",?114,"Vol." ;126

 W !,?25,"Provider(s)",?60,"Synonym",!,?60,"- Modifier(s)" ;126

 W !,DASH ;126 Removed extra line feed

 Q

 ;

FOOTER ;print page footer

 W !!?4,"Volume totals may represent days, minutes, numbers of procedures"

 W !?4,"and/or a combination of these."

 Q

 ;

EXIT ;common exit point

 D ^ECKILL

 D:'$D(ECGUI) ^%ZISC

 K ^TMP("ECOS",$J)

 K JJ,X,Y,ZTSK,IO("Q"),DIR,DIRUT,DTOUT,DUOUT,ECOS,ECOSN,ECSD,ECED,ECLOOP,ECLOC,ECDSSU

 Q

 ;

EXPORT ;119 Section added for exporting data to excel

 N CNT,LOC,UNIT,PAT,IEN,DATA,SUB,MODCNT,PRCNT

 S CNT=1,^TMP($J,"ECRPT",CNT)="ORDERING SECTION^LOCATION^DSS UNIT^PATIENT^SSN^CPT CODE^PROCEDURE CODE^PROCEDURE NAME (DESCRIPTION)^SYNONYM^VOLUME" ;126

 S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_"^CPT MOD #1^CPT MOD #2^CPT MOD #3^PROVIDER #1^PROVIDER #2^PROVIDER #3^PROVIDER #4^PROVIDER #5^PROVIDER #6^PROVIDER #7" ;126

 I '$D(^TMP("ECOS",$J)) Q  ;Nothing to report

 S LOC="" F  S LOC=$O(^TMP("ECOS",$J,LOC)) Q:LOC=""  D

 .S UNIT="" F  S UNIT=$O(^TMP("ECOS",$J,LOC,UNIT)) Q:UNIT=""  D

 ..S PAT="" F  S PAT=$O(^TMP("ECOS",$J,LOC,UNIT,PAT)) Q:PAT=""  D

 ...S IEN=0 F  S IEN=$O(^TMP("ECOS",$J,LOC,UNIT,PAT,IEN)) Q:'+IEN  D

 ....S DATA=^TMP("ECOS",$J,LOC,UNIT,PAT,IEN)

 ....S CNT=CNT+1,^TMP($J,"ECRPT",CNT)=ECOSN_U_LOC_U_UNIT_U_$P(PAT,U)_U_$P(DATA,U)_U_$P(DATA,U,2)_U_$P(DATA,U,3)_U_$P(DATA,U,4)_U_$P(DATA,U,5)_U_$P(DATA,U,6) ;126

 ....S SUB=0,MODCNT=0 F  S:SUB'="" SUB=$O(^TMP("ECOS",$J,LOC,UNIT,PAT,IEN,"MOD",SUB)) Q:MODCNT=3  S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_U_$S(SUB'="":SUB_" "_$P($G(^TMP("ECOS",$J,LOC,UNIT,PAT,IEN,"MOD",SUB)),U,3),1:""),MODCNT=MODCNT+1

 ....S SUB=0,PRCNT=0 F  S:SUB'="" SUB=$O(^TMP("ECOS",$J,LOC,UNIT,PAT,IEN,"PRV",SUB)) Q:PRCNT=7  S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_U_$S(SUB="":"",1:$P($G(^TMP("ECOS",$J,LOC,UNIT,PAT,IEN,"PRV",SUB)),U,2)) S PRCNT=PRCNT+1

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ECOSSUM   10430     printed  Feb 18, 2025@23:24:37                                                                                                                                                                                                    Page 2

ECOSSUM   ;BIR/DMA,RHK,JPW - Ordering Section Summary ;11/18/14  16:03

 +1       ;;2.0;EVENT CAPTURE;**5,8,18,47,72,95,119,126**;8 May 96;Build 8

EN        ;entry point from menu option

 +1        WRITE !

 +2        KILL DIC

           SET DIC=723

           SET DIC(0)="AQEMZ"

           SET DIC("A")="Select Ordering Section: "

           DO ^DIC

           KILL DIC

 +3        IF Y<0

               GOTO EXIT

 +4        SET ECOS=+Y

           SET ECOSN=$PIECE(Y,"^",2)

 +5        DO RANGE

 +6        IF '$GET(ECLOOP)!'$GET(ECSD)!'$GET(ECED)

               GOTO EXIT

 +7        WRITE !

 +8        SET JJ=$$ASKLOC^ECRUTL

 +9        IF 'JJ

               GOTO EXIT

 +10       WRITE !

 +11       SET JJ=$$ASKDSS^ECRUTL

 +12       IF 'JJ

               GOTO EXIT

 +13       WRITE !

 +14       DO DEVICE

 +15       IF POP

               GOTO EXIT

 +16       IF $GET(ZTSK)

               GOTO EXIT

 +17       IF $GET(IO("Q"))

               IF '$GET(ZTSK)

                   GOTO EXIT

 +18       DO START

 +19       DO HOME^%ZIS

 +20       GOTO EXIT

 +21       QUIT 

 +22      ;

START     ;queued entry point or continuation

 +1        DO PROCESS

 +2       ;119

           IF $GET(ECPTYP)="E"

               DO EXPORT

               DO EXIT

               QUIT 

 +3        USE IO

           DO PRINT

 +4        IF $DATA(ECGUI)

               DO EXIT

               QUIT 

 +5        IF IO'=IO(0)

               DO ^%ZISC

 +6        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               DO EXIT

 +7        QUIT 

 +8       ;

RANGE     ;get any date range

 +1        NEW ECSTDT,ECENDDT

 +2        WRITE !!,?5,"Enter a Begin Date and End Date for the Event Capture "

 +3        WRITE !,?5,"Ordering Section report.",!

 +4        SET (ECSD,ECED)=0

 +5        FOR 

               Begin DoDot:1

 +6                SET ECLOOP=$$STDT^ECRUTL()

                   IF 'ECLOOP

                       QUIT 

 +7                SET ECSD=ECSTDT

               End DoDot:1

               if ECSD>0

                   QUIT 

               if '$GET(ECLOOP)

                   QUIT 

 +8        if '$GET(ECLOOP)!'$GET(ECSD)

               QUIT 

 +9        FOR 

               Begin DoDot:1

 +10               SET ECLOOP=$$ENDDT^ECRUTL(ECSTDT)

                   IF 'ECLOOP

                       QUIT 

 +11               SET ECED=ECENDDT

 +12               IF ECED>(DT+1)

                       Begin DoDot:2

 +13                       WRITE !!,?15,"The End Date for this report may not be"

 +14                       WRITE !,?15,"a future date.  Try again...",!

 +15                       SET ECED=0

                       End DoDot:2

               End DoDot:1

               if ECED>0

                   QUIT 

               if '$GET(ECLOOP)

                   QUIT 

 +16       QUIT 

 +17      ;

DEVICE    ;select output device

 +1        WRITE !,"This report is formatted for 132 column output.",!

 +2        KILL IOP

           SET %ZIS="QM"

           DO ^%ZIS

 +3        IF POP

               WRITE !!,"No device selected.  Exiting...",!!

               SET DIR(0)="E"

               WRITE !

               DO ^DIR

               KILL DIR

               QUIT 

 +4        IF $DATA(IO("Q"))

               Begin DoDot:1

 +5                SET ZTRTN="START^ECOSSUM"

                   SET ZTDESC="EC Ordering Section Summary"

 +6                SET ZTSAVE("ECSD")=""

                   SET ZTSAVE("ECED")=""

                   SET ZTSAVE("ECOS")=""

                   SET ZTSAVE("ECOSN")=""

 +7                SET ZTSAVE("ECLOC(")=""

                   SET ZTSAVE("ECDSSU(")=""

 +8                DO ^%ZTLOAD

 +9                IF '$GET(ZTSK)

                       WRITE !,"Report canceled..."

                       SET DIR(0)="E"

                       WRITE !

                       DO ^DIR

                       KILL DIR

                       QUIT 

 +10               WRITE !,"Report queued as Task #: ",ZTSK

                   SET DIR(0)="E"

                   WRITE !

                   DO ^DIR

                   KILL DIR

               End DoDot:1

 +11       QUIT 

 +12      ;

PROCESS   ;get data to print

 +1       ;119

           NEW EC,ECD,ECDA,ECPA,ECPATN,ECSS,ECSSN,ECP,ECPN,ECLOCA,ECUNIT,ECCAT,ECFILE,ECPSY,ECPSYN,ECPRV,ECPRVN,EC725,ECLOCN,ECUNITN,ECEPN,ECEPC

 +2        NEW NLOC,NUNIT,JJ,ECPXD

 +3        KILL ^TMP("ECOS",$JOB)

 +4       ;put locations and units into ien subscripted arrays

 +5        SET JJ=""

           FOR 

               SET JJ=$ORDER(ECLOC(JJ))

               if JJ=""

                   QUIT 

               Begin DoDot:1

 +6                SET NLOC($PIECE(ECLOC(JJ),"^",1))=$PIECE(ECLOC(JJ),"^",2)

               End DoDot:1

 +7        SET JJ=""

           FOR 

               SET JJ=$ORDER(ECDSSU(JJ))

               if JJ=""

                   QUIT 

               Begin DoDot:1

 +8                SET NUNIT($PIECE(ECDSSU(JJ),"^",1))=$PIECE(ECDSSU(JJ),"^",2)

               End DoDot:1

 +9        SET ECD=ECSD

 +10       FOR 

               SET ECD=$ORDER(^ECH("AC",ECD))

               if 'ECD

                   QUIT 

               if ECD>ECED

                   QUIT 

               Begin DoDot:1

 +11               SET ECDA=""

                   FOR 

                       SET ECDA=$ORDER(^ECH("AC",ECD,ECDA))

                       if 'ECDA

                           QUIT 

                       SET EC=$GET(^ECH(ECDA,0))

                       IF $PIECE(EC,"^",12)=ECOS

                           Begin DoDot:2

 +12      ;file or x-ref problem

                               IF $PIECE(EC,"^",3)<ECSD!($PIECE(EC,"^",3)>ECED)

                                   QUIT 

 +13                           SET ECLOCA=+$PIECE(EC,U,4)

                               SET ECUNIT=+$PIECE(EC,U,7)

 +14                           IF '$DATA(NLOC(ECLOCA))!('$DATA(NUNIT(ECUNIT)))

                                   QUIT 

 +15      ;119 Get location and unit names

                               SET ECLOCN=$GET(NLOC(ECLOCA))

                               SET ECUNITN=$GET(NUNIT(ECUNIT))

 +16                           SET ECP=$PIECE(EC,U,9)

                               if ECP']""

                                   QUIT 

 +17                           SET ECCAT=+$PIECE(EC,U,8)

 +18                           SET ECPSY=+$ORDER(^ECJ("AP",ECLOCA,ECUNIT,ECCAT,ECP,""))

 +19                           SET ECPSYN=$PIECE($GET(^ECJ(ECPSY,"PRO")),"^",2)

 +20                           SET ECFILE=$PIECE(ECP,";",2)

                               SET ECFILE=$SELECT($EXTRACT(ECFILE)="I":81,$EXTRACT(ECFILE)="E":725,1:"UNKNOWN")

 +21      ;119

                               IF ECFILE="UNKNOWN"

                                   SET (ECPN,ECEPN)="UNKNOWN"

 +22      ;119

                               SET ECCPT=$SELECT(ECFILE=81:+ECP,1:$PIECE($GET(^EC(725,+ECP,0)),"^",5))

                               SET ECPXD=""

                               SET ECEPC=""

 +23                           IF ECCPT'=""

                                   Begin DoDot:3

 +24                                   SET ECPXD=$$CPT^ICPTCOD(ECCPT,$PIECE(EC,"^",3))

                                       SET ECCPT=$PIECE(ECPXD,"^",2)

                                   End DoDot:3

 +25      ;119

                               IF ECFILE=81

                                   SET (ECPN,ECEPN)=$SELECT($PIECE(ECPXD,"^",3)]"":$PIECE(ECPXD,"^",3),1:"UNKNOWN")

 +26                           IF ECFILE=725

                                   Begin DoDot:3

 +27      ;119

                                       SET EC725=$GET(^EC(725,+ECP,0))

                                       SET ECPN=$PIECE(EC725,"^",2)_" "_$PIECE(EC725,"^")

                                       SET ECEPN=$PIECE(EC725,U)

                                       SET ECEPC=$PIECE(EC725,U,2)

                                   End DoDot:3

 +28      ;119,126

                               SET ECPN=ECPN_"~"_ECCPT

 +29      ;ALB/JAM - Get Procedure CPT modifiers

 +30                           SET ECMODF=0

                               IF $ORDER(^ECH(ECDA,"MOD",0))'=""

                                   Begin DoDot:3

 +31                                   KILL ECMOD

                                       SET ECMODF=$$MOD^ECUTL(ECDA,"E",.ECMOD)

                                   End DoDot:3

 +32                           SET (ECPA,ECPATN,ECSS)=""

                               SET ECPA=$GET(^DPT(+$PIECE(EC,"^",2),0))

                               if ECPA=""

                                   QUIT 

 +33                           SET ECPATN=$PIECE(ECPA,"^",1)

                               SET ECSS=$PIECE(ECPA,"^",9)

 +34                           if +ECSS

                                   SET ECSSN=$EXTRACT(ECSS,6,10)

                               if ECSS=""

                                   SET ECSSN="UNKN"

 +35                           if ECPATN=""

                                   SET ECPATN="UNKNOWN"

                               SET ECPATN=ECPATN_"^"_ECSSN

 +36                           SET ECV=+$PIECE(EC,"^",10)

 +37                           KILL ECPRV

                               SET ECPRV=$$GETPRV^ECPRVMUT(ECDA,.ECPRV)

                               IF 'ECPRV

                                   Begin DoDot:3

 +38      ;119 Use names rather than numbers if exporting

                                       MERGE ^TMP("ECOS",$JOB,$SELECT($GET(ECPTYP)="E":ECLOCN,1:ECLOCA),$SELECT($GET(ECPTYP)="E":ECUNITN,1:ECUNIT),ECPATN,ECDA,"PRV")=ECPRV

                                   End DoDot:3

                                   KILL ECPRV

 +39      ;119,126

                               IF $GET(ECPTYP)'="E"

                                   SET ^TMP("ECOS",$JOB,ECLOCA,ECUNIT,ECPATN,ECDA)=ECSSN_"^"_ECPN_"^"_ECPSYN_"^"_ECV

 +40      ;119,126

                               if $GET(ECPTYP)="E"

                                   SET ^TMP("ECOS",$JOB,ECLOCN,ECUNITN,ECPATN,ECDA)=ECSSN_U_ECCPT_U_ECEPC_U_ECEPN_U_ECPSYN_U_ECV

 +41                           IF ECMODF

                                   Begin DoDot:3

 +42      ;119 use names rather than numbers when exporting

                                       MERGE ^TMP("ECOS",$JOB,$SELECT($GET(ECPTYP)="E":ECLOCN,1:ECLOCA),$SELECT($GET(ECPTYP)="E":ECUNITN,1:ECUNIT),ECPATN,ECDA,"MOD")=ECMOD

                                   End DoDot:3

                           End DoDot:2

               End DoDot:1

 +43       QUIT 

 +44      ;

PRINT     ;output report

 +1       ;126

           NEW ECDA,ECLOCA,ECUNIT,ECPATN,ECSSN,ECPN,ECV,ECPSYN

 +2        NEW PAGE,QFLAG,DASH,DASH2,PRNTDT,JJ,SS,ALOC,AUNIT,LOC,UNNAME,UNIT,DATA,PTNAME,PROV,PROVN,V,X,Y

 +3        SET (PAGE,QFLAG)=0

           SET $PIECE(DASH,"-",130)=""

           SET $PIECE(DASH2,"-",64)=""

 +4        SET Y=$PIECE(ECSD,".",1)+1

           DO DD^%DT

           SET ECSD=Y

           SET Y=$PIECE(ECED,".",1)

           DO DD^%DT

           SET ECED=Y

 +5        DO NOW^%DTC

           SET Y=$EXTRACT(%,1,12)

           DO DD^%DT

           SET PRNTDT=Y

 +6        SET ECV("L")=0

           SET ECV("O")=0

           SET ECV("P")=0

           SET ECV("U")=0

 +7       ;if no data exists then print the header and quit

 +8        IF '$DATA(^TMP("ECOS",$JOB))

               Begin DoDot:1

 +9                SET LOC=""

                   DO HEAD

 +10               WRITE !!,?26,"No data for this Ordering Section for the date range specified.",!!

 +11               IF $EXTRACT(IOST)="C"&('QFLAG)

                       SET DIR(0)="E"

                       Begin DoDot:2

 +12                       SET SS=22-$Y

                           FOR JJ=1:1:SS

                               WRITE !

                       End DoDot:2

                       DO ^DIR

                       KILL DIR

 +13               if $EXTRACT(IOST)'="C"

                       WRITE @IOF

               End DoDot:1

               QUIT 

 +14      ;if there's data in ^TMP then need to present the data alphabetically;

 +15      ;put locations and units in alpha ordered array

 +16       SET JJ=""

           FOR 

               SET JJ=$ORDER(ECLOC(JJ))

               if JJ=""

                   QUIT 

               Begin DoDot:1

 +17               SET ALOC($PIECE(ECLOC(JJ),"^",2))=$PIECE(ECLOC(JJ),"^",1)

               End DoDot:1

 +18       SET JJ=""

           FOR 

               SET JJ=$ORDER(ECDSSU(JJ))

               if JJ=""

                   QUIT 

               Begin DoDot:1

 +19               SET AUNIT($PIECE(ECDSSU(JJ),"^",2))=$PIECE(ECDSSU(JJ),"^",1)

               End DoDot:1

 +20      ;process the ^TMP global data in alpha order for location and unit

 +21       SET LOC=""

           FOR 

               SET LOC=$ORDER(ALOC(LOC))

               if LOC=""

                   QUIT 

               SET ECLOCA=ALOC(LOC)

               SET ECV("L")=0

               Begin DoDot:1

 +22      ;always start a new location at top of page

                   DO HEAD

                   if QFLAG

                       QUIT 

 +23               SET UNIT=""

                   FOR 

                       SET UNIT=$ORDER(AUNIT(UNIT))

                       if UNIT=""

                           QUIT 

                       SET ECUNIT=AUNIT(UNIT)

                       SET ECV("U")=0

                       Begin DoDot:2

 +24                       IF '$DATA(^TMP("ECOS",$JOB,ECLOCA,ECUNIT))

                               QUIT 

 +25                       SET UNNAME=$EXTRACT(UNIT,1,20)

 +26      ;126 Removed excess linefeed

                           if ($Y+6>IOSL)

                               DO HEAD

                           if QFLAG

                               QUIT 

                           WRITE !,UNNAME

 +27                       SET ECPATN=""

                           FOR 

                               SET ECPATN=$ORDER(^TMP("ECOS",$JOB,ECLOCA,ECUNIT,ECPATN))

                               if ECPATN=""

                                   QUIT 

                               SET ECV("P")=0

                               Begin DoDot:3

 +28                               SET PTNAME=$PIECE(ECPATN,"^",1)

                                   SET PTNAME=$EXTRACT(PTNAME,1,22)

                                   SET ECSSN=$PIECE(ECPATN,"^",2)