- 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 Apr 23, 2025@18:13:10 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
