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
;
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 ---[H[J[2J[HECOSSUM 10430 printed Apr 09, 2024@21:01: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)
+29 WRITE ?24,PTNAME,?48,ECSSN
+30 SET ECDA=""
FOR
SET ECDA=$ORDER(^TMP("ECOS",$JOB,ECLOCA,ECUNIT,ECPATN,ECDA))
if ECDA=""
QUIT
SET DATA=^(ECDA)
Begin DoDot:4
+31 ;126
SET ECPN=$PIECE(DATA,"^",2)
SET ECPN=$SELECT($PIECE(ECPN,"~",2)'="":$JUSTIFY($PIECE(ECPN,"~",2)_" ",6),1:"")_$PIECE(ECPN,"~")
+32 ;126
SET ECV=$PIECE(DATA,"^",4)
SET ECV=ECV\1
SET ECPSYN=$PIECE(DATA,U,3)
Begin DoDot:5
+33 FOR V="L","O","P","U"
SET ECV(V)=ECV(V)+ECV
+34 ;unusually high individual volume figure
if +ECV>9999
SET ECV="9999+"
SET ECV=$$RJ^XLFSTR(ECV,5," ")
End DoDot:5
+35 KILL PROV
MERGE PROV=^TMP("ECOS",$JOB,ECLOCA,ECUNIT,ECPATN,ECDA,"PRV")
+36 KILL ECMOD
MERGE ECMOD=^TMP("ECOS",$JOB,ECLOCA,ECUNIT,ECPATN,ECDA,"MOD")
+37 ;126
WRITE ?54,ECPN,?112,ECV,!,?25,$PIECE($GET(PROV(1)),"^",2),?60,ECPSYN
KILL PROV(1)
+38 if ($Y+6>IOSL)
DO HEAD
if QFLAG
QUIT
+39 ;ALB/JAM - write cpt procedure modifiers on same line with providers
+40 SET MOD=0
SET PROVN=1
FOR
SET MOD=$ORDER(ECMOD(MOD))
SET PROVN=$ORDER(PROV(PROVN))
if (MOD="")&(PROVN="")
QUIT
Begin DoDot:5
+41 IF ($Y+6>IOSL)
DO HEAD
if QFLAG
QUIT
WRITE !?54,ECPN
+42 WRITE !
+43 ;126
IF PROVN'=""
WRITE ?25,$PIECE($GET(PROV(PROVN)),"^",2)
KILL PROV(PROVN)
+44 ;126
IF MOD'=""
WRITE ?60,"- ",MOD," ",$PIECE(ECMOD(MOD),U,3)
KILL ECMOD(MOD)
End DoDot:5
IF QFLAG
QUIT
+45 ;start a new line
WRITE !
End DoDot:4
if QFLAG
QUIT
+46 ;write subtotal for patient
+47 if QFLAG
QUIT
if ($Y+6>IOSL)
DO HEAD
if QFLAG
QUIT
+48 WRITE ?54,DASH2,!
+49 ;126
WRITE ?24,"Subtotal for "_$PIECE(ECPATN,"^",1)_":",?112,$$RJ^XLFSTR(ECV("P"),5," "),!!
End DoDot:3
if QFLAG
QUIT
+50 ;write total for unit
+51 if QFLAG
QUIT
if ($Y+6>IOSL)
DO HEAD
if QFLAG
QUIT
+52 ;126
WRITE !,"Subtotal for DSS Unit "_UNIT_":",?111,$$RJ^XLFSTR(ECV("U"),6," "),!
End DoDot:2
if QFLAG
QUIT
+53 ;write the total for the location
+54 if QFLAG
QUIT
if ($Y+6>IOSL)
DO HEAD
if QFLAG
QUIT
+55 ;126
WRITE !!,"Total for Location "_LOC_":",?111,$$RJ^XLFSTR(ECV("L"),6," "),!
End DoDot:1
if QFLAG
QUIT
+56 ;write the ordering section grandtotal
+57 if QFLAG
QUIT
if ($Y+8>IOSL)
DO HEAD
if QFLAG
QUIT
+58 ;126
WRITE !!!,"Grand Total for Ordering Section "_ECOSN_":",?111,$$RJ^XLFSTR(ECV("O"),6," "),!
+59 ;all done
+60 ;print footer on last page
DO FOOTER
+61 IF $EXTRACT(IOST)="C"&('QFLAG)
SET DIR(0)="E"
Begin DoDot:1
+62 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
End DoDot:1
DO ^DIR
WRITE @IOF
+63 if $EXTRACT(IOST)'="C"
WRITE @IOF
+64 QUIT
HEAD ;header
+1 IF $EXTRACT(IOST)="C"
SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+2 IF PAGE>0
DO FOOTER
+3 IF $EXTRACT(IOST)="C"
IF PAGE>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLAG=1
QUIT
+4 if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
+5 SET PAGE=PAGE+1
+6 WRITE !,?26,"Event Capture Ordering Section Summary for ",ECOSN,?105,"Page: ",PAGE
+7 WRITE !,?26,"for the Date Range ",$$FMTE^XLFDT(ECSD)," to ",$$FMTE^XLFDT(ECED),?102,"Printed: "_PRNTDT
+8 WRITE !,?26,"Location: ",LOC,!
+9 ;126
WRITE !,"DSS Unit",?24,"Patient",?48,"SSN",?54,"Procedure",?114,"Vol."
+10 ;126
WRITE !,?25,"Provider(s)",?60,"Synonym",!,?60,"- Modifier(s)"
+11 ;126 Removed extra line feed
WRITE !,DASH
+12 QUIT
+13 ;
+1 WRITE !!?4,"Volume totals may represent days, minutes, numbers of procedures"
+2 WRITE !?4,"and/or a combination of these."
+3 QUIT
+4 ;
EXIT ;common exit point
+1 DO ^ECKILL
+2 if '$DATA(ECGUI)
DO ^%ZISC
+3 KILL ^TMP("ECOS",$JOB)
+4 KILL JJ,X,Y,ZTSK,IO("Q"),DIR,DIRUT,DTOUT,DUOUT,ECOS,ECOSN,ECSD,ECED,ECLOOP,ECLOC,ECDSSU
+5 QUIT
+6 ;
EXPORT ;119 Section added for exporting data to excel
+1 NEW CNT,LOC,UNIT,PAT,IEN,DATA,SUB,MODCNT,PRCNT
+2 ;126
SET CNT=1
SET ^TMP($JOB,"ECRPT",CNT)="ORDERING SECTION^LOCATION^DSS UNIT^PATIENT^SSN^CPT CODE^PROCEDURE CODE^PROCEDURE NAME (DESCRIPTION)^SYNONYM^VOLUME"
+3 ;126
SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"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"
+4 ;Nothing to report
IF '$DATA(^TMP("ECOS",$JOB))
QUIT
+5 SET LOC=""
FOR
SET LOC=$ORDER(^TMP("ECOS",$JOB,LOC))
if LOC=""
QUIT
Begin DoDot:1
+6 SET UNIT=""
FOR
SET UNIT=$ORDER(^TMP("ECOS",$JOB,LOC,UNIT))
if UNIT=""
QUIT
Begin DoDot:2
+7 SET PAT=""
FOR
SET PAT=$ORDER(^TMP("ECOS",$JOB,LOC,UNIT,PAT))
if PAT=""
QUIT
Begin DoDot:3
+8 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("ECOS",$JOB,LOC,UNIT,PAT,IEN))
if '+IEN
QUIT
Begin DoDot:4
+9 SET DATA=^TMP("ECOS",$JOB,LOC,UNIT,PAT,IEN)
+10 ;126
SET CNT=CNT+1
SET ^TMP($JOB,"ECRPT",CNT)=ECOSN_U_LOC_U_UNIT_U_$PIECE(PAT,U)_U_$PIECE(DATA,U)_U_$PIECE(DATA,U,2)_U_$PIECE(DATA,U,3)_U_$PIECE(DATA,U,4)_U_$PIECE(DATA,U,5)_U_$PIECE(DATA,U,6)
+11 SET SUB=0
SET MODCNT=0
FOR
if SUB'=""
SET SUB=$ORDER(^TMP("ECOS",$JOB,LOC,UNIT,PAT,IEN,"MOD",SUB))
if MODCNT=3
QUIT
SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_U_$SELECT(SUB'="":SUB_" "_$PIECE($GET(^TMP("ECOS",$JOB,LOC,UNIT,PAT,IEN,"MOD",SUB)),U,3),1:"")
SET MODCNT=MODCNT+1
+12 SET SUB=0
SET PRCNT=0
FOR
if SUB'=""
SET SUB=$ORDER(^TMP("ECOS",$JOB,LOC,UNIT,PAT,IEN,"PRV",SUB))
if PRCNT=7
QUIT
SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_U_$SELECT(SUB="":"",1:$PIECE($GET(^TMP("ECOS",$JOB,LOC,UNIT,PAT,IEN,"PRV",SUB)),U,2))
SET PRCNT=PRCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
