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 ---[H[J[2J[HECRPRSN 9968 printed Nov 22, 2024@17:08:50 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
SET ECSSN=$EXTRACT(ECSS,6,9)
if ECSS=""
SET ECSSN="UNKNOWN"
+34 if ECPATN=""
SET ECPATN="UNKNOWN"
SET ECPATN=ECPATN_"^"_ECSSN
+35 SET (ECPRV,ECPRVN)=""
SET ECPRV=$$GETPPRV^ECPRVMUT(ECDA,.ECPRVN)
SET ECPRVN=$SELECT(ECPRV:"UNKNOWN",1:ECPRVN)
+36 ;ALB/JAM - Get CPT modifiers
SET ECMD=""
IF $ORDER(^ECH(ECDA,"MOD",0))'=""
Begin DoDot:3
+37 KILL ECMOD
SET ECMODF=$$MOD^ECUTL(ECDA,"I",.ECMOD)
SET SEQ=""
IF 'ECMODF
QUIT
+38 FOR
SET SEQ=$ORDER(ECMOD(SEQ))
if SEQ=""
QUIT
SET ECMD=ECMD_$SELECT(ECMD="":"",1:";")_$PIECE(ECMOD(SEQ),"^",2)
End DoDot:3
+39 IF ECMD=""
SET ECMD="NOMOD"
+40 SET ^TMP("ECREAS",$JOB,ECLOCA,ECUNIT,ECRN,$EXTRACT(ECPN,1,15))=ECDESC
+41 SET ^TMP("ECREAS",$JOB,ECLOCA,ECUNIT,ECRN,$EXTRACT(ECPN,1,15),ECMD,ECDFN,ECD)=ECPRVN_"^"_ECPATN
+42 ;where ecloca, ecunit,ecdfn are iens, ecdt is internal format
End DoDot:2
End DoDot:1
+43 QUIT
PRINT ;output report
+1 NEW ECLOCA,ECUNIT,ECREASN,ECDT,ECED2,ECSD2,ECPATN,ECPN,ECPRVN,SEQ,X,Y,SSN
+2 NEW PAGE,QFLAG,DASH,PRNTDT,JJ,SS,ALOC,AUNIT,DATE,LOC,UNIT,PTNAME,PROVN,ECDESC
+3 SET (PAGE,QFLAG)=0
SET $PIECE(DASH,"-",80)=""
+4 SET Y=$PIECE(ECSD,".",1)+1
DO DD^%DT
SET ECSD2=Y
SET Y=$PIECE(ECED,".",1)
DO DD^%DT
SET ECED2=Y
+5 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET PRNTDT=Y
+6 ;if no data exists then print the header and quit
+7 IF '$DATA(^TMP("ECREAS",$JOB))
Begin DoDot:1
+8 SET (LOC,UNIT)=""
DO HEAD
+9 WRITE !!,?6,"No data for the date range specified.",!!
+10 IF $EXTRACT(IOST)="C"&('QFLAG)
SET DIR(0)="E"
Begin DoDot:2
+11 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
End DoDot:2
DO ^DIR
KILL DIR
+12 if $EXTRACT(IOST)'="C"
WRITE @IOF
End DoDot:1
QUIT
+13 ;if there's data in ^TMP then need to present the data alphabetically;
+14 ;put locations and units in alpha ordered array
+15 SET JJ=""
FOR
SET JJ=$ORDER(ECLOC(JJ))
if JJ=""
QUIT
Begin DoDot:1
+16 SET ALOC($PIECE(ECLOC(JJ),"^",2))=$PIECE(ECLOC(JJ),"^",1)
End DoDot:1
+17 SET JJ=""
FOR
SET JJ=$ORDER(ECDSSU(JJ))
if JJ=""
QUIT
Begin DoDot:1
+18 SET AUNIT($PIECE(ECDSSU(JJ),"^",2))=$PIECE(ECDSSU(JJ),"^",1)
End DoDot:1
+19 ;process the ^TMP global data in alpha order for location and unit
+20 SET LOC=""
FOR
SET LOC=$ORDER(ALOC(LOC))
if LOC=""
QUIT
SET ECLOCA=ALOC(LOC)
Begin DoDot:1
+21 SET UNIT=""
FOR
SET UNIT=$ORDER(AUNIT(UNIT))
if UNIT=""
QUIT
SET ECUNIT=AUNIT(UNIT)
Begin DoDot:2
+22 ;always start a location at top of page
+23 IF $DATA(^TMP("ECREAS",$JOB,ECLOCA,ECUNIT))
DO HEAD
DO LOOP
End DoDot:2
if QFLAG
QUIT
End DoDot:1
if QFLAG
QUIT
+24 ;all done
+25 IF $EXTRACT(IOST)="C"&('QFLAG)
SET DIR(0)="E"
Begin DoDot:1
+26 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
End DoDot:1
DO ^DIR
WRITE @IOF
+27 if $EXTRACT(IOST)'="C"
WRITE @IOF
+28 QUIT
LOOP ;print the section of the ^tmp global for a specific location/unit
+1 SET ECREASN=""
+2 FOR
SET ECREASN=$ORDER(^TMP("ECREAS",$JOB,ECLOCA,ECUNIT,ECREASN))
if ECREASN=""
QUIT
if QFLAG
QUIT
Begin DoDot:1
+3 if ($Y+3>IOSL)
DO HEAD
if QFLAG
QUIT
WRITE !!,"Reason: ",ECREASN,!
SET ECPN=""
+4 FOR
SET ECPN=$ORDER(^TMP("ECREAS",$JOB,ECLOCA,ECUNIT,ECREASN,ECPN))
if ECPN=""
QUIT
if QFLAG
QUIT
Begin DoDot:2
+5 SET ECDESC=$GET(^TMP("ECREAS",$JOB,ECLOCA,ECUNIT,ECREASN,ECPN))
SET ECMOD=""
+6 FOR
SET ECMOD=$ORDER(^TMP("ECREAS",$JOB,ECLOCA,ECUNIT,ECREASN,ECPN,ECMOD))
if ECMOD=""
QUIT
Begin DoDot:3
+7 WRITE !,?3,"Procedure: ",ECDESC
if ECMOD'="NOMOD"
DO MODPRT
if QFLAG
QUIT
DO LOOP1
End DoDot:3
if QFLAG
QUIT
End DoDot:2
End DoDot:1
+8 QUIT
LOOP1 SET ECPATN=""
FOR
SET ECPATN=$ORDER(^TMP("ECREAS",$JOB,ECLOCA,ECUNIT,ECREASN,ECPN,ECMOD,ECPATN))
if ECPATN=""
QUIT
if QFLAG
QUIT
Begin DoDot:1
+1 SET ECDT=""
FOR
SET ECDT=$ORDER(^TMP("ECREAS",$JOB,ECLOCA,ECUNIT,ECREASN,ECPN,ECMOD,ECPATN,ECDT))
if ECDT=""
QUIT
if QFLAG
QUIT
Begin DoDot:2
+2 SET ECPRVN=^(ECDT)
SET PTNAME=$PIECE(ECPRVN,"^",3)
SET PTNAME=$EXTRACT(PTNAME,1,22)
+3 SET SSN=$PIECE(ECPRVN,"^",4)
SET ECPRVN=$PIECE(ECPRVN,"^",2)
+4 SET Y=ECDT
DO DD^%DT
SET DATE=$EXTRACT(Y,1,18)
SET PROVN=$EXTRACT(ECPRVN,1,22)
+5 if ($Y+3>IOSL)
DO HEAD
if QFLAG
QUIT
WRITE !,?6,PTNAME,?30,SSN,?37,DATE,?57,PROVN
End DoDot:2
End DoDot:1
+6 WRITE !
+7 QUIT
MODPRT ;ALB/JAM - print CPT procedure modifiers
+1 NEW MOD,I,MODESC,IEN,MODI
+2 WRITE !?4,"Modifier: "
+3 FOR I=1:1
SET IEN=$PIECE(ECMOD,";",I)
if IEN=""
QUIT
Begin DoDot:1
+4 SET MODI=$$MOD^ICPTMOD(IEN,"E",$PIECE(ECED,"."))
SET MOD=$PIECE(MODI,"^",2)
IF MOD=""
QUIT
+5 SET MODESC=$PIECE(MODI,"^",3)
IF MODESC="UNKNOWN"
QUIT
+6 if I>1
WRITE !
WRITE ?18,"- ",MOD," ",MODESC
IF ($Y+3)>IOSL
DO HEAD
End DoDot:1
IF QFLAG
QUIT
+7 QUIT
HEAD ;header
+1 IF $EXTRACT(IOST)="C"
SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+2 IF $EXTRACT(IOST)="C"
IF PAGE>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLAG=1
QUIT
+3 if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
+4 SET PAGE=PAGE+1
+5 WRITE !,?12,"Event Capture Procedure Reason Report"
+6 WRITE !,?12,"for the Date Range ",$$FMTE^XLFDT(ECSD2)," to ",$$FMTE^XLFDT(ECED2),!
+7 WRITE !,?3,"DSS Unit: ",UNIT,?55,"Page: ",PAGE
+8 WRITE !,?3,"Location: ",LOC,?52,"Printed: "_PRNTDT,!
+9 WRITE !?6,"Patient",?30,"SSN",?37,"Date/Time",?57,"Provider"
+10 WRITE !,DASH
+11 QUIT
EXIT ;common exit point
+1 DO ^ECKILL
if '$DATA(ECGUI)
DO ^%ZISC
+2 KILL ^TMP("ECREAS",$JOB)
KILL JJ,X,Y,ZTSK,IO("Q"),DIR,DIRUT,DTOUT,DUOUT,ECSD
+3 KILL ECED,ECLOOP,ECLOC,ECDSSU,ECLINK,ASK,DIC
+4 QUIT
