ECRPRSN2 ;ALB/DAN - Updated Procedure Reasons Report;24 JAN 07 ;9/30/14 17:18
;;2.0;EVENT CAPTURE;**112,126**;8 May 96;Build 8
STRPT ;queued entry point or continuation
D PROCESS
I ECPTYP="E" D EXPORT D EXIT Q
U IO D PRINT Q:$D(ECGUI)
I IO'=IO(0) D ^%ZISC
I $D(ZTQUEUED) S ZTREQ="@"
D EXIT
Q
PROCESS ;get data to print
N EC,ECD,ECDA,ECPA,ECR,ECRL,ECRN,ECPATN,ECSSN,ECP,ECLOCA
N ECUNIT,ECFILE,ECPRV,ECPRVN,ECDFN,ECCPT
N NLOC,NUNIT,JJ,REAS,ECRSNUM,ECPI,ECPROCNM ;126
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
..F REAS=34,43,44 S ECRL=$$GET1^DIQ(721,ECDA,REAS,"I") I +ECRL I $D(ECLINK(ECRL)) S ECR=ECLINK(ECRL),ECRN=$P($G(^ECR(ECR,0)),"^") I ECRN'="" S ECRSNUM=$S(REAS=34:1,REAS=43:2,1:3) D
...S ECP=$P(EC,U,9) Q:ECP']""
...S ECPROCNM=$$GETPRNM^ECRDSSA(ECP,ECD) ;126 Get procedure name from file entry
...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)),"^",2))
...I ECCPT'=""&(ECFILE=81) D
....S ECPI=$$CPT^ICPTCOD(ECCPT,$P(ECED,".")) I +ECPI>1 S ECCPT=$P(ECPI,"^",2)
...S (ECPA,ECPATN)="",ECPA=$G(^DPT(+$P(EC,"^",2),0)) Q:ECPA=""
...S ECPATN=$P(ECPA,"^",1),ECSSN=$E($P(ECPA,"^",9),6,9)
...S:ECPATN="" ECPATN="UNKNOWN"
...S (ECPRV,ECPRVN)="",ECPRV=$$GETPPRV^ECPRVMUT(ECDA,.ECPRVN),ECPRVN=$S(ECPRV:"UNKNOWN",1:ECPRVN)
...S ^TMP("ECREAS",$J,NLOC(ECLOCA),NUNIT(ECUNIT)_"~"_ECUNIT,ECRN,ECPATN,ECD)=ECRSNUM_"^"_$P(ECPRVN,U,2)_"^"_ECSSN_"^"_ECCPT_"^"_ECPROCNM ;126
Q
PRINT ;output report
N ECED2,ECSD2,Y,DSSU,REAS,PAT,DATE,DATA,PAGE,QFLAG,DASH,PRNTDT,LOC,%
S (PAGE,QFLAG)=0 S $P(DASH,"-",132)=""
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="" 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
S LOC="" F S LOC=$O(^TMP("ECREAS",$J,LOC)) Q:LOC="" D HEAD S DSSU="" F S DSSU=$O(^TMP("ECREAS",$J,LOC,DSSU)) Q:DSSU="" W !,"DSS Unit: ",$P(DSSU,"~",1)_" (IEN "_$P(DSSU,"~",2)_")" D W !
.S REAS="" F S REAS=$O(^TMP("ECREAS",$J,LOC,DSSU,REAS)) Q:REAS="" D
..S PAT="" F S PAT=$O(^TMP("ECREAS",$J,LOC,DSSU,REAS,PAT)) Q:PAT="" S DATE="" F S DATE=$O(^TMP("ECREAS",$J,LOC,DSSU,REAS,PAT,DATE)) Q:'+DATE D
...S DATA=^TMP("ECREAS",$J,LOC,DSSU,REAS,PAT,DATE)
...W !,?3,REAS,?37,$P(DATA,U),?41,$P(DATA,U,4),?52,$P(DATA,U,5),?118,$$FMTE^XLFDT(DATE,2),!,?43,PAT,?75,$P(DATA,U,3),?81,$P(DATA,U,2) ;126
...I $Y>(IOSL-4) 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 !,?47,"Event Capture Procedure Reasons Report",?123,"Page: ",PAGE
W !,?43,"for the Date Range ",$$FMTE^XLFDT(ECSD2)," to ",$$FMTE^XLFDT(ECED2),!,?53,"Printed: "_PRNTDT,!
W !,"Location: ",LOC,!
W ?3,"PROCEDURE REASON",?35,"RSN#",?41,"PROC CODE",?52,"PROCEDURE NAME",?118,"DATE/TIME",!,?43,"PATIENT",?75,"SSN",?81,"PROVIDER" ;126
W !,DASH
Q
EXIT ;common exit point
D:'$D(ECGUI) ^%ZISC
K ^TMP("ECREAS",$J)
Q
;
EXPORT ;Convert data to exportable format
N LOC,DSSU,REAS,PAT,DATE,CNT,DATA
K ^TMP($J,"ECRPT") ;make sure there isn't anything here before it's populated
S CNT=1,^TMP($J,"ECRPT",CNT)="LOCATION^DSS UNIT^DSS UNIT IEN^REASON TEXT^REASON #^PROC CODE^PROCEDURE NAME^SSN^PATIENT^DATE/TIME^PROVIDER" ;126
S LOC="" F S LOC=$O(^TMP("ECREAS",$J,LOC)) Q:LOC="" S DSSU="" F S DSSU=$O(^TMP("ECREAS",$J,LOC,DSSU)) Q:DSSU="" S REAS="" F S REAS=$O(^TMP("ECREAS",$J,LOC,DSSU,REAS)) Q:REAS="" D
.S PAT="" F S PAT=$O(^TMP("ECREAS",$J,LOC,DSSU,REAS,PAT)) Q:PAT="" S DATE="" F S DATE=$O(^TMP("ECREAS",$J,LOC,DSSU,REAS,PAT,DATE)) Q:'+DATE D
..S DATA=^TMP("ECREAS",$J,LOC,DSSU,REAS,PAT,DATE)
..S CNT=CNT+1,^TMP($J,"ECRPT",CNT)=LOC_U_$P(DSSU,"~",1)_U_$P(DSSU,"~",2)_U_REAS_U_$P(DATA,U,1)_U_$P(DATA,U,4)_U_$P(DATA,U,5)_U_$P(DATA,U,3)_U_PAT_U_$$FMTE^XLFDT(DATE,2)_U_$P(DATA,U,2) ;126
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECRPRSN2 4792 printed Nov 22, 2024@17:08:51 Page 2
ECRPRSN2 ;ALB/DAN - Updated Procedure Reasons Report;24 JAN 07 ;9/30/14 17:18
+1 ;;2.0;EVENT CAPTURE;**112,126**;8 May 96;Build 8
STRPT ;queued entry point or continuation
+1 DO PROCESS
+2 IF ECPTYP="E"
DO EXPORT
DO EXIT
QUIT
+3 USE IO
DO PRINT
if $DATA(ECGUI)
QUIT
+4 IF IO'=IO(0)
DO ^%ZISC
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 DO EXIT
+7 QUIT
PROCESS ;get data to print
+1 NEW EC,ECD,ECDA,ECPA,ECR,ECRL,ECRN,ECPATN,ECSSN,ECP,ECLOCA
+2 NEW ECUNIT,ECFILE,ECPRV,ECPRVN,ECDFN,ECCPT
+3 ;126
NEW NLOC,NUNIT,JJ,REAS,ECRSNUM,ECPI,ECPROCNM
+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 FOR REAS=34,43,44
SET ECRL=$$GET1^DIQ(721,ECDA,REAS,"I")
IF +ECRL
IF $DATA(ECLINK(ECRL))
SET ECR=ECLINK(ECRL)
SET ECRN=$PIECE($GET(^ECR(ECR,0)),"^")
IF ECRN'=""
SET ECRSNUM=$SELECT(REAS=34:1,REAS=43:2,1:3)
Begin DoDot:3
+19 SET ECP=$PIECE(EC,U,9)
if ECP']""
QUIT
+20 ;126 Get procedure name from file entry
SET ECPROCNM=$$GETPRNM^ECRDSSA(ECP,ECD)
+21 SET ECFILE=$PIECE(ECP,";",2)
SET ECFILE=$SELECT($EXTRACT(ECFILE)="I":81,$EXTRACT(ECFILE)="E":725,1:"UNKNOWN")
+22 SET ECCPT=$SELECT(ECFILE=81:+ECP,1:$PIECE($GET(^EC(725,+ECP,0)),"^",2))
+23 IF ECCPT'=""&(ECFILE=81)
Begin DoDot:4
+24 SET ECPI=$$CPT^ICPTCOD(ECCPT,$PIECE(ECED,"."))
IF +ECPI>1
SET ECCPT=$PIECE(ECPI,"^",2)
End DoDot:4
+25 SET (ECPA,ECPATN)=""
SET ECPA=$GET(^DPT(+$PIECE(EC,"^",2),0))
if ECPA=""
QUIT
+26 SET ECPATN=$PIECE(ECPA,"^",1)
SET ECSSN=$EXTRACT($PIECE(ECPA,"^",9),6,9)
+27 if ECPATN=""
SET ECPATN="UNKNOWN"
+28 SET (ECPRV,ECPRVN)=""
SET ECPRV=$$GETPPRV^ECPRVMUT(ECDA,.ECPRVN)
SET ECPRVN=$SELECT(ECPRV:"UNKNOWN",1:ECPRVN)
+29 ;126
SET ^TMP("ECREAS",$JOB,NLOC(ECLOCA),NUNIT(ECUNIT)_"~"_ECUNIT,ECRN,ECPATN,ECD)=ECRSNUM_"^"_$PIECE(ECPRVN,U,2)_"^"_ECSSN_"^"_ECCPT_"^"_ECPROCNM
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT
PRINT ;output report
+1 NEW ECED2,ECSD2,Y,DSSU,REAS,PAT,DATE,DATA,PAGE,QFLAG,DASH,PRNTDT,LOC,%
+2 SET (PAGE,QFLAG)=0
SET $PIECE(DASH,"-",132)=""
+3 SET Y=$PIECE(ECSD,".",1)+1
DO DD^%DT
SET ECSD2=Y
SET Y=$PIECE(ECED,".",1)
DO DD^%DT
SET ECED2=Y
+4 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET PRNTDT=Y
+5 ;if no data exists then print the header and quit
+6 IF '$DATA(^TMP("ECREAS",$JOB))
Begin DoDot:1
+7 SET LOC=""
DO HEAD
+8 WRITE !!,?6,"No data for the date range specified.",!!
+9 IF $EXTRACT(IOST)="C"&('QFLAG)
SET DIR(0)="E"
Begin DoDot:2
+10 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
End DoDot:2
DO ^DIR
KILL DIR
+11 if $EXTRACT(IOST)'="C"
WRITE @IOF
End DoDot:1
QUIT
+12 SET LOC=""
FOR
SET LOC=$ORDER(^TMP("ECREAS",$JOB,LOC))
if LOC=""
QUIT
DO HEAD
SET DSSU=""
FOR
SET DSSU=$ORDER(^TMP("ECREAS",$JOB,LOC,DSSU))
if DSSU=""
QUIT
WRITE !,"DSS Unit: ",$PIECE(DSSU,"~",1)_" (IEN "_$PIECE(DSSU,"~",2)_")"
Begin DoDot:1
+13 SET REAS=""
FOR
SET REAS=$ORDER(^TMP("ECREAS",$JOB,LOC,DSSU,REAS))
if REAS=""
QUIT
Begin DoDot:2
+14 SET PAT=""
FOR
SET PAT=$ORDER(^TMP("ECREAS",$JOB,LOC,DSSU,REAS,PAT))
if PAT=""
QUIT
SET DATE=""
FOR
SET DATE=$ORDER(^TMP("ECREAS",$JOB,LOC,DSSU,REAS,PAT,DATE))
if '+DATE
QUIT
Begin DoDot:3
+15 SET DATA=^TMP("ECREAS",$JOB,LOC,DSSU,REAS,PAT,DATE)
+16 ;126
WRITE !,?3,REAS,?37,$PIECE(DATA,U),?41,$PIECE(DATA,U,4),?52,$PIECE(DATA,U,5),?118,$$FMTE^XLFDT(DATE,2),!,?43,PAT,?75,$PIECE(DATA,U,3),?81,$PIECE(DATA,U,2)
+17 IF $Y>(IOSL-4)
DO HEAD
End DoDot:3
End DoDot:2
End DoDot:1
WRITE !
+18 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 !,?47,"Event Capture Procedure Reasons Report",?123,"Page: ",PAGE
+6 WRITE !,?43,"for the Date Range ",$$FMTE^XLFDT(ECSD2)," to ",$$FMTE^XLFDT(ECED2),!,?53,"Printed: "_PRNTDT,!
+7 WRITE !,"Location: ",LOC,!
+8 ;126
WRITE ?3,"PROCEDURE REASON",?35,"RSN#",?41,"PROC CODE",?52,"PROCEDURE NAME",?118,"DATE/TIME",!,?43,"PATIENT",?75,"SSN",?81,"PROVIDER"
+9 WRITE !,DASH
+10 QUIT
EXIT ;common exit point
+1 if '$DATA(ECGUI)
DO ^%ZISC
+2 KILL ^TMP("ECREAS",$JOB)
+3 QUIT
+4 ;
EXPORT ;Convert data to exportable format
+1 NEW LOC,DSSU,REAS,PAT,DATE,CNT,DATA
+2 ;make sure there isn't anything here before it's populated
KILL ^TMP($JOB,"ECRPT")
+3 ;126
SET CNT=1
SET ^TMP($JOB,"ECRPT",CNT)="LOCATION^DSS UNIT^DSS UNIT IEN^REASON TEXT^REASON #^PROC CODE^PROCEDURE NAME^SSN^PATIENT^DATE/TIME^PROVIDER"
+4 SET LOC=""
FOR
SET LOC=$ORDER(^TMP("ECREAS",$JOB,LOC))
if LOC=""
QUIT
SET DSSU=""
FOR
SET DSSU=$ORDER(^TMP("ECREAS",$JOB,LOC,DSSU))
if DSSU=""
QUIT
SET REAS=""
FOR
SET REAS=$ORDER(^TMP("ECREAS",$JOB,LOC,DSSU,REAS))
if REAS=""
QUIT
Begin DoDot:1
+5 SET PAT=""
FOR
SET PAT=$ORDER(^TMP("ECREAS",$JOB,LOC,DSSU,REAS,PAT))
if PAT=""
QUIT
SET DATE=""
FOR
SET DATE=$ORDER(^TMP("ECREAS",$JOB,LOC,DSSU,REAS,PAT,DATE))
if '+DATE
QUIT
Begin DoDot:2
+6 SET DATA=^TMP("ECREAS",$JOB,LOC,DSSU,REAS,PAT,DATE)
+7 ;126
SET CNT=CNT+1
SET ^TMP($JOB,"ECRPT",CNT)=LOC_U_$PIECE(DSSU,"~",1)_U_$PIECE(DSSU,"~",2)_U_REAS_U_$PIECE(DATA,U,1)_U_$PIECE(DATA,U,4)_U_$PIECE(DATA,U,5)_U_$PIECE(DATA,U,3)_U_PAT_U_$$FMTE^XLFDT(DATE,2)_U_$PIECE(DATA,U,2)
End DoDot:2
End DoDot:1
+8 QUIT
