ECRPRSN.m

ECRPRSN ;ALB/JAP - Procedure Reasons Report;24 JAN 07

 ;;2.0; EVENT CAPTURE ;**5,18,47,63,72,91**;8 May 96;Build 2

EN ;entry point from menu option

 N JJ

 W ! S JJ=$$ASKLOC^ECRUTL I 'JJ G EXIT

 W ! S JJ=$$ASKDSS^ECRUTL I 'JJ G EXIT

 W ! S JJ=$$ASKREAS() I 'JJ G EXIT

 W !

 D RANGE

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

 W ! D DEVICE I POP G EXIT

 I $G(ZTSK) G EXIT

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

 D START,HOME^%ZIS

 G EXIT

 Q

START ;queued entry point or continuation

 D PROCESS

 U IO D PRINT Q:$D(ECGUI)

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

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

 Q

ASKREAS()        ; Ask reasons

 ;   output: ECREAS array; contains set of reason iens

 N DIRUT,DUOUT,DTOUT,Y,DIR,A,P,R,S,JJ,KK,NLOC,NUNIT,LINK,ECREAS,E

 ;setup array of associated reason iens for the locations/units included

 W !!,"Just a moment please..."

 W !,?5,"...finding Procedure Reasons related to the"

 W !,?5,"   Location(s) and DSS Unit(s) you selected...",!

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

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

 .S KK="" F  S KK=$O(ECDSSU(KK)) Q:KK=""  S NUNIT=$P(ECDSSU(KK),"^",1),A(NLOC_"-"_NUNIT)=""

 S P=""

 F  S P=$O(^ECJ("B",P)) Q:P=""  I $D(A($P(P,"-",1,2))) S I=$O(^ECJ("B",P,"")),S(I)=""

 K A S P="" F  S P=$O(^ECL("AD",P)) Q:P=""  I $D(S(P)) S R="" D

 .F  S R=$O(^ECL("AD",P,R)) Q:R=""  D

 ..S LINK=$O(^ECL("AD",P,R,"")),ECLINK(LINK)=R

 ..S ECREAS(R)=$P($G(^ECR(R,0)),"^",1)

 ..I ECREAS(R)="" K ECREAS(R),ECLINK(LINK)

 K S

 ;ask the user to include all reasons or selected reasons

 S ASK=1

 S DIR(0)="YA",DIR("A")="Do you want to print this report for all Procedure Reasons? "

 S DIR("B")="YES" W ! D ^DIR K DIR I Y=0,'$G(DIRUT) D SPECR

 I $G(DIRUT)!(Y=0) S ASK=0 K ECREAS

 ;display user selections

 I $D(ECREAS)>1 D

 .W @IOF S E=0 W !,"Selected Procedure Reasons --",!

 .S R="" F  S R=$O(ECREAS(R)) Q:R=""  D  I E Q

 ..I $Y+3>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y E=1 Q:'Y  D

 ...W @IOF,!,"Selected Procedure Reasons (cont.) --",!

 ..W !,?5,ECREAS(R)

 .Q:E  S DIR(0)="E" D  D ^DIR K DIR

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

 Q ASK

SPECR ;specific reasons

 N R,DUOUT,DTOUT

 K DIRUT,Y

 S DIR(0)="YA",DIR("A")="Do you want to include only specific Procedure Reasons in this report? ",DIR("B")="YES"

 S DIR("?")="Enter YES to select specific Procedure Reasons or NO to quit."

 W ! D ^DIR K DIR Q:$G(DIRUT)!(Y=0)

 ;select subset of possible reasons

 K DIRUT,DTOUT,DUOUT,Y

 F  D  Q:$G(DIRUT)!(Y=-1)

 .S DIC=720.4,DIC("A")="Select a Procedure Reason to include: ",DIC(0)="QAEM"

 .S DIC("S")="I $D(ECREAS(+Y))"

 .W ! D ^DIC Q:$G(DUOUT)!$G(DTOUT)!(Y=-1)

 .S R(+Y)=""

 S:$G(DTOUT)!($G(DUOUT)) DIRUT=1

 Q:$G(DIRUT)

 ;delete reasons from ecreas array which were not selected

 I $D(R)<10 S Y=0 Q

 S R="" F  S R=$O(ECREAS(R)) Q:R=""  I '$D(R(R)) K ECREAS(R)

 ;delete links from eclink array for reasons not selected

 S LINK="" F  S LINK=$O(ECLINK(LINK)) Q:LINK=""  S R=ECLINK(LINK) I '$D(ECREAS(R)) K ECLINK(LINK)

 S Y=1

 Q

RANGE ;get any date range

 N ECSTDT,ECENDDT

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

 W !,?5,"Procedure Reason 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 ! K IOP,ZTSK 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^ECRPRSN",ZTDESC="EC Procedure Reason Report"

 .S ZTSAVE("ECSD")="",ZTSAVE("ECED")="",ZTSAVE("ECLOC(")="",ZTSAVE("ECDSSU(")="",ZTSAVE("ECLINK(")=""

 .D ^%ZTLOAD D HOME^%ZIS

 .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,ECR,ECRL,ECRN,ECPATN,ECSS,ECSSN,ECP,ECPN,ECLOCA

 N ECUNIT,ECCAT,ECFILE,ECPSY,ECPSYN,ECPRV,ECPRVN,ECDFN,ECCPT,ECDESC

 N NLOC,NUNIT,JJ,ECMOD,ECMD,ECMODF,EC725

 K ^TMP("ECREAS",$J)

 ;if ecreas array doesn't exist, quit

 I $D(ECLINK)<10 Q

 ;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,"^",23)'="" D

 ..S ECDFN=$P(EC,"^")

 ..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 ECRL=$P(EC,"^",23) Q:'$D(ECLINK(ECRL))  S ECR=ECLINK(ECRL),ECRN=$P($G(^ECR(ECR,0)),"^") Q:ECRN']""

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

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

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

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

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

 ..I ECCPT'="" D

 ...S ECPI=$$CPT^ICPTCOD(ECCPT,$P(ECED,".")) I +ECPI>1 S ECCPT=$P(ECPI,"^",2)_" "

 ..I ECFILE="UNKNOWN" S ECPN="UNKNOWN"

 ..I ECFILE=81 S ECPN=$S($P(ECPI,"^",3)]"":$P(ECPI,"^",3),1:"UNKNOWN")

 ..I ECFILE=725 S EC725=$G(^EC(725,+ECP,0)),ECPN=$P(EC725,"^",2)_" "_$P(EC725,"^")

 ..Q:ECPN=""

 ..S ECDESC=$J(ECCPT_" ",6)_$E(ECPN,1,40)_$S(ECPSYN]"":" ["_ECPSYN_"] ",1:"")

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

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

 ..S:+ECSS ECSSN=$E(ECSS,6,9) S:ECSS="" ECSSN="UNKNOWN"

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

 ..S (ECPRV,ECPRVN)="",ECPRV=$$GETPPRV^ECPRVMUT(ECDA,.ECPRVN),ECPRVN=$S(ECPRV:"UNKNOWN",1:ECPRVN)

 ..S ECMD="" I $O(^ECH(ECDA,"MOD",0))'="" D  ;ALB/JAM - Get CPT modifiers

 ...K ECMOD S ECMODF=$$MOD^ECUTL(ECDA,"I",.ECMOD),SEQ="" I 'ECMODF Q

 ...F  S SEQ=$O(ECMOD(SEQ)) Q:SEQ=""  S ECMD=ECMD_$S(ECMD="":"",1:";")_$P(ECMOD(SEQ),"^",2)

 ..I ECMD="" S ECMD="NOMOD"

 ..S ^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECRN,$E(ECPN,1,15))=ECDESC

 ..S ^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECRN,$E(ECPN,1,15),ECMD,ECDFN,ECD)=ECPRVN_"^"_ECPATN

 ..;where ecloca, ecunit,ecdfn are iens, ecdt is internal format

 Q

PRINT ;output report

 N ECLOCA,ECUNIT,ECREASN,ECDT,ECED2,ECSD2,ECPATN,ECPN,ECPRVN,SEQ,X,Y,SSN

 N PAGE,QFLAG,DASH,PRNTDT,JJ,SS,ALOC,AUNIT,DATE,LOC,UNIT,PTNAME,PROVN,ECDESC

 S (PAGE,QFLAG)=0 S $P(DASH,"-",80)=""

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

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

 ;if no data exists then print the header and quit

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

 .S (LOC,UNIT)="" D HEAD

 .W !!,?6,"No data 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) D  Q:QFLAG

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

 ..;always start a location at top of page

 ..I $D(^TMP("ECREAS",$J,ECLOCA,ECUNIT)) D HEAD D LOOP

 ;all done

 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

LOOP ;print the section of the ^tmp global for a specific location/unit

 S ECREASN=""

 F  S ECREASN=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN)) Q:ECREASN=""  Q:QFLAG  D

 .D:($Y+3>IOSL) HEAD Q:QFLAG  W !!,"Reason: ",ECREASN,! S ECPN=""

 .F  S ECPN=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN)) Q:ECPN=""  Q:QFLAG  D

 ..S ECDESC=$G(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN)),ECMOD=""

 ..F  S ECMOD=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN,ECMOD)) Q:ECMOD=""  D  Q:QFLAG

 ...W !,?3,"Procedure: ",ECDESC D:ECMOD'="NOMOD" MODPRT Q:QFLAG  D LOOP1

 Q

LOOP1 S ECPATN="" F  S ECPATN=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN,ECMOD,ECPATN)) Q:ECPATN=""  Q:QFLAG  D

 .S ECDT="" F  S ECDT=$O(^TMP("ECREAS",$J,ECLOCA,ECUNIT,ECREASN,ECPN,ECMOD,ECPATN,ECDT)) Q:ECDT=""  Q:QFLAG  D

 ..S ECPRVN=^(ECDT),PTNAME=$P(ECPRVN,"^",3),PTNAME=$E(PTNAME,1,22)

 ..S SSN=$P(ECPRVN,"^",4),ECPRVN=$P(ECPRVN,"^",2)

 ..S Y=ECDT D DD^%DT S DATE=$E(Y,1,18),PROVN=$E(ECPRVN,1,22)

 ..D:($Y+3>IOSL) HEAD Q:QFLAG  W !,?6,PTNAME,?30,SSN,?37,DATE,?57,PROVN

 W !

 Q

MODPRT ;ALB/JAM - print CPT procedure modifiers

 N MOD,I,MODESC,IEN,MODI

 W !?4,"Modifier: "

 F I=1:1 S IEN=$P(ECMOD,";",I) Q:IEN=""  D  I QFLAG Q

 . S MODI=$$MOD^ICPTMOD(IEN,"E",$P(ECED,".")),MOD=$P(MODI,"^",2) I MOD="" Q

 . S MODESC=$P(MODI,"^",3) I MODESC="UNKNOWN" Q

 . W:I>1 ! W ?18,"- ",MOD," ",MODESC I ($Y+3)>IOSL D HEAD

 Q

HEAD ;header

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

 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 !,?12,"Event Capture Procedure Reason Report"

 W !,?12,"for the Date Range ",$$FMTE^XLFDT(ECSD2)," to ",$$FMTE^XLFDT(ECED2),!

 W !,?3,"DSS Unit: ",UNIT,?55,"Page: ",PAGE

 W !,?3,"Location: ",LOC,?52,"Printed: "_PRNTDT,!

 W !?6,"Patient",?30,"SSN",?37,"Date/Time",?57,"Provider"

 W !,DASH

 Q

EXIT ;common exit point

 D ^ECKILL D:'$D(ECGUI) ^%ZISC

 K ^TMP("ECREAS",$J) K JJ,X,Y,ZTSK,IO("Q"),DIR,DIRUT,DTOUT,DUOUT,ECSD

 K ECED,ECLOOP,ECLOC,ECDSSU,ECLINK,ASK,DIC

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ECRPRSN   9968     printed  Mar 13, 2025@21:03:31                                                                                                                                                                                                     Page 2

ECRPRSN   ;ALB/JAP - Procedure Reasons Report;24 JAN 07

 +1       ;;2.0; EVENT CAPTURE ;**5,18,47,63,72,91**;8 May 96;Build 2

EN        ;entry point from menu option

 +1        NEW JJ

 +2        WRITE !

           SET JJ=$$ASKLOC^ECRUTL

           IF 'JJ

               GOTO EXIT

 +3        WRITE !

           SET JJ=$$ASKDSS^ECRUTL

           IF 'JJ

               GOTO EXIT

 +4        WRITE !

           SET JJ=$$ASKREAS()

           IF 'JJ

               GOTO EXIT

 +5        WRITE !

 +6        DO RANGE

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

               GOTO EXIT

 +8        WRITE !

           DO DEVICE

           IF POP

               GOTO EXIT

 +9        IF $GET(ZTSK)

               GOTO EXIT

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

               IF '$GET(ZTSK)

                   GOTO EXIT

 +11       DO START

           DO HOME^%ZIS

 +12       GOTO EXIT

 +13       QUIT 

START     ;queued entry point or continuation

 +1        DO PROCESS

 +2        USE IO

           DO PRINT

           if $DATA(ECGUI)

               QUIT 

 +3        IF IO'=IO(0)

               DO ^%ZISC

 +4        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               DO EXIT

 +5        QUIT 

ASKREAS() ; Ask reasons

 +1       ;   output: ECREAS array; contains set of reason iens

 +2        NEW DIRUT,DUOUT,DTOUT,Y,DIR,A,P,R,S,JJ,KK,NLOC,NUNIT,LINK,ECREAS,E

 +3       ;setup array of associated reason iens for the locations/units included

 +4        WRITE !!,"Just a moment please..."

 +5        WRITE !,?5,"...finding Procedure Reasons related to the"

 +6        WRITE !,?5,"   Location(s) and DSS Unit(s) you selected...",!

 +7        SET JJ=""

           FOR 

               SET JJ=$ORDER(ECLOC(JJ))

               if JJ=""

                   QUIT 

               Begin DoDot:1

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

 +9                SET KK=""

                   FOR 

                       SET KK=$ORDER(ECDSSU(KK))

                       if KK=""

                           QUIT 

                       SET NUNIT=$PIECE(ECDSSU(KK),"^",1)

                       SET A(NLOC_"-"_NUNIT)=""

               End DoDot:1

 +10       SET P=""

 +11       FOR 

               SET P=$ORDER(^ECJ("B",P))

               if P=""

                   QUIT 

               IF $DATA(A($PIECE(P,"-",1,2)))

                   SET I=$ORDER(^ECJ("B",P,""))

                   SET S(I)=""

 +12       KILL A

           SET P=""

           FOR 

               SET P=$ORDER(^ECL("AD",P))

               if P=""

                   QUIT 

               IF $DATA(S(P))

                   SET R=""

                   Begin DoDot:1

 +13                   FOR 

                           SET R=$ORDER(^ECL("AD",P,R))

                           if R=""

                               QUIT 

                           Begin DoDot:2

 +14                           SET LINK=$ORDER(^ECL("AD",P,R,""))

                               SET ECLINK(LINK)=R

 +15                           SET ECREAS(R)=$PIECE($GET(^ECR(R,0)),"^",1)

 +16                           IF ECREAS(R)=""

                                   KILL ECREAS(R),ECLINK(LINK)

                           End DoDot:2

                   End DoDot:1

 +17       KILL S

 +18      ;ask the user to include all reasons or selected reasons

 +19       SET ASK=1

 +20       SET DIR(0)="YA"

           SET DIR("A")="Do you want to print this report for all Procedure Reasons? "

 +21       SET DIR("B")="YES"

           WRITE !

           DO ^DIR

           KILL DIR

           IF Y=0

               IF '$GET(DIRUT)

                   DO SPECR

 +22       IF $GET(DIRUT)!(Y=0)

               SET ASK=0

               KILL ECREAS

 +23      ;display user selections

 +24       IF $DATA(ECREAS)>1

               Begin DoDot:1

 +25               WRITE @IOF

                   SET E=0

                   WRITE !,"Selected Procedure Reasons --",!

 +26               SET R=""

                   FOR 

                       SET R=$ORDER(ECREAS(R))

                       if R=""

                           QUIT 

                       Begin DoDot:2

 +27                       IF $Y+3>IOSL

                               SET DIR(0)="E"

                               DO ^DIR

                               KILL DIR

                               if 'Y

                                   SET E=1

                               if 'Y

                                   QUIT 

                               Begin DoDot:3

 +28                               WRITE @IOF,!,"Selected Procedure Reasons (cont.) --",!

                               End DoDot:3

 +29                       WRITE !,?5,ECREAS(R)

                       End DoDot:2

                       IF E

                           QUIT 

 +30               if E

                       QUIT 

                   SET DIR(0)="E"

                   Begin DoDot:2

 +31                   SET SS=22-$Y

                       FOR JJ=1:1:SS

                           WRITE !

                   End DoDot:2

                   DO ^DIR

                   KILL DIR

               End DoDot:1

 +32       QUIT ASK

SPECR     ;specific reasons

 +1        NEW R,DUOUT,DTOUT

 +2        KILL DIRUT,Y

 +3        SET DIR(0)="YA"

           SET DIR("A")="Do you want to include only specific Procedure Reasons in this report? "

           SET DIR("B")="YES"

 +4        SET DIR("?")="Enter YES to select specific Procedure Reasons or NO to quit."

 +5        WRITE !

           DO ^DIR

           KILL DIR

           if $GET(DIRUT)!(Y=0)

               QUIT 

 +6       ;select subset of possible reasons

 +7        KILL DIRUT,DTOUT,DUOUT,Y

 +8        FOR 

               Begin DoDot:1

 +9                SET DIC=720.4

                   SET DIC("A")="Select a Procedure Reason to include: "

                   SET DIC(0)="QAEM"

 +10               SET DIC("S")="I $D(ECREAS(+Y))"

 +11               WRITE !

                   DO ^DIC

                   if $GET(DUOUT)!$GET(DTOUT)!(Y=-1)

                       QUIT 

 +12               SET R(+Y)=""

               End DoDot:1

               if $GET(DIRUT)!(Y=-1)

                   QUIT 

 +13       if $GET(DTOUT)!($GET(DUOUT))

               SET DIRUT=1

 +14       if $GET(DIRUT)

               QUIT 

 +15      ;delete reasons from ecreas array which were not selected

 +16       IF $DATA(R)<10

               SET Y=0

               QUIT 

 +17       SET R=""

           FOR 

               SET R=$ORDER(ECREAS(R))

               if R=""

                   QUIT 

               IF '$DATA(R(R))

                   KILL ECREAS(R)

 +18      ;delete links from eclink array for reasons not selected

 +19       SET LINK=""

           FOR 

               SET LINK=$ORDER(ECLINK(LINK))

               if LINK=""

                   QUIT 

               SET R=ECLINK(LINK)

               IF '$DATA(ECREAS(R))

                   KILL ECLINK(LINK)

 +20       SET Y=1

 +21       QUIT 

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,"Procedure Reason 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 !

           KILL IOP,ZTSK

           SET %ZIS="QM"

           DO ^%ZIS

 +2        IF POP

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

               SET DIR(0)="E"

               WRITE !

               DO ^DIR

               KILL DIR

               QUIT 

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

               Begin DoDot:1

 +4                SET ZTRTN="START^ECRPRSN"

                   SET ZTDESC="EC Procedure Reason Report"

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

                   SET ZTSAVE("ECED")=""

                   SET ZTSAVE("ECLOC(")=""

                   SET ZTSAVE("ECDSSU(")=""

                   SET ZTSAVE("ECLINK(")=""

 +6                DO ^%ZTLOAD

                   DO HOME^%ZIS

 +7                IF '$GET(ZTSK)

                       WRITE !,"Report canceled..."

                       SET DIR(0)="E"

                       WRITE !

                       DO ^DIR

                       KILL DIR

                       QUIT 

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

                   SET DIR(0)="E"

                   WRITE !

                   DO ^DIR

                   KILL DIR

               End DoDot:1

 +9        QUIT 

 +10      ;

PROCESS   ;get data to print

 +1        NEW EC,ECD,ECDA,ECPA,ECR,ECRL,ECRN,ECPATN,ECSS,ECSSN,ECP,ECPN,ECLOCA

 +2        NEW ECUNIT,ECCAT,ECFILE,ECPSY,ECPSYN,ECPRV,ECPRVN,ECDFN,ECCPT,ECDESC

 +3        NEW NLOC,NUNIT,JJ,ECMOD,ECMD,ECMODF,EC725

 +4        KILL ^TMP("ECREAS",$JOB)

 +5       ;if ecreas array doesn't exist, quit

 +6        IF $DATA(ECLINK)<10

               QUIT 

 +7       ;put locations and units into ien subscripted arrays

 +8        SET JJ=""

           FOR 

               SET JJ=$ORDER(ECLOC(JJ))

               if JJ=""

                   QUIT 

               Begin DoDot:1

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

               End DoDot:1

 +10       SET JJ=""

           FOR 

               SET JJ=$ORDER(ECDSSU(JJ))

               if JJ=""

                   QUIT 

               Begin DoDot:1

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

               End DoDot:1

 +12       SET ECD=ECSD

           FOR 

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

               if 'ECD

                   QUIT 

               if ECD>ECED

                   QUIT 

               Begin DoDot:1

 +13               SET ECDA=""

                   FOR 

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

                       if 'ECDA

                           QUIT 

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

                       IF $PIECE(EC,"^",23)'=""

                           Begin DoDot:2

 +14                           SET ECDFN=$PIECE(EC,"^")

 +15      ;file or x-ref problem

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

                                   QUIT 

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

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

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

                                   QUIT 

 +18                           SET ECRL=$PIECE(EC,"^",23)

                               if '$DATA(ECLINK(ECRL))

                                   QUIT 

                               SET ECR=ECLINK(ECRL)

                               SET ECRN=$PIECE($GET(^ECR(ECR,0)),"^")

                               if ECRN']""

                                   QUIT 

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

                               if ECP']""

                                   QUIT 

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

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

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

                               SET ECPI=""

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

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

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

 +24                           IF ECCPT'=""

                                   Begin DoDot:3

 +25                                   SET ECPI=$$CPT^ICPTCOD(ECCPT,$PIECE(ECED,"."))

                                       IF +ECPI>1

                                           SET ECCPT=$PIECE(ECPI,"^",2)_" "

                                   End DoDot:3

 +26                           IF ECFILE="UNKNOWN"

                                   SET ECPN="UNKNOWN"

 +27                           IF ECFILE=81

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

 +28                           IF ECFILE=725

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

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

 +29                           if ECPN=""

                                   QUIT 

 +30                           SET ECDESC=$JUSTIFY(ECCPT_" ",6)_$EXTRACT(ECPN,1,40)_$SELECT(ECPSYN]"":" ["_ECPSYN_"] ",1:"")

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

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

                               if ECPA=""

                                   QUIT 

 +32                           SET ECPATN=$EXTRACT($PIECE(ECPA,"^",1),1,24)

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

 +33                           if +ECSS