- ECPRSUM1 ;BIR/DMA,RHK,JPW - Provider Summary (1 to 7) ;12/2/14 11:09
- ;;2.0;EVENT CAPTURE;**5,18,33,47,62,63,61,72,88,95,112,119,126**;8 May 96;Build 8
- ;In patch 119, temporary data storage for the report was moved from
- ;^TMP($J to ^TMP("ECTMP",$J so that the exportable version of the
- ;report, which is returned in ^TMP($J,"ECRPT", wouldn't be deleted upon
- ;completion. That change occurred in many lines in this routine.
- ;
- S DIC=200,DIC(0)="AQEMZ",DIC("A")="Select Provider: "
- D ^DIC K DIC G END:Y<0 S ECU=+Y,ECUN=$P(Y,"^",2)
- ;D REASON^ECRUTL ;* Prompt to include Procedure Reasons. 112, Remove reasons from report
- I ($D(DIRUT))!($D(DUOUT)) G END
- BDATE K %DT S %DT="AEX",%DT("A")="Starting with Date: "
- D ^%DT G:Y<0 END S ECSD=Y
- EDATE K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT G:Y<0 END
- I Y<ECSD D G EDATE
- .W !!,"The ending date cannot be earlier than the starting date. "
- .W "Please re-enter",!,"the ending date.",!
- S ECED=Y,ECDATE=ECSD_"^"_ECED
- DEV ;dev call
- W !!,"This report is formatted for 132 column output.",!!
- S %ZIS="Q",%ZIS("A")="Select Device: " D ^%ZIS G END:POP
- I $D(IO("Q")) K ZTSAVE S (ZTSAVE("ECRY"),ZTSAVE("ECSD"),ZTSAVE("ECDATE"),ZTSAVE("ECED"),ZTSAVE("ECU"),ZTSAVE("ECUN"))="",ZTDESC="Event Capture Provider Summary",ZTRTN="EN^ECPRSUM1" D ^%ZTLOAD,HOME^%ZIS K ZTSK G END
- ;
- EN ;QUEUED ENTRY POINT
- N ECPG,ECGT,EC,ECCAT,ECPXD,MODI,ECI,ECPRV,RK,A,ECX,EC725,ECEPN,ECLOCN,ECUNITN ;119,126
- I $G(ECPTYP)'="E" U IO ;119 Only need IO if not exporting
- S (ECOUT,ECPG)=0 F ECI=1:1:7 S ECGT(ECI)=0,A(ECI)=0
- K ^TMP("ECTMP",$J) S ECOUT=0,ECSD=ECSD-.1,ECED=ECED+.3
- F ECD=ECSD:0 S ECD=$O(^ECH("AC",ECD)) Q:'ECD Q:ECD>ECED F DA=0:0 S DA=$O(^ECH("AC",ECD,DA)) Q:'DA I $D(^ECH("APRV",ECU,DA)) S EC=$G(^ECH(DA,0)) D
- .K ECPRV S ECPRV=$$GETPRV^ECPRVMUT(DA,.ECPRV),ECX=0 I ECPRV Q
- .F ECI=1:1:7 S A(ECI)=0
- .F ECI=1:1:7 S ECX=$O(ECPRV(ECX)) Q:'ECX D
- ..S A(ECI)=$P(ECPRV(ECX),U)=ECU
- .S ECX=A(1)=A(2)=A(3)=A(4)=A(5)=A(6)=A(7) I 'ECX Q
- .S ECPAT=+$P(EC,"^",2),PA=$G(^DPT(ECPAT,0)),SS=$P(PA,"^",9)
- .S PA=$S($P(PA,"^")]"":$P(PA,"^"),1:"UNKNOWN"),ECP=$P(EC,"^",9)
- .Q:ECP']""
- .S ECLOC=+$P(EC,U,4),ECUNIT=+$P(EC,U,7),ECCAT=+$P(EC,U,8)
- .I $G(ECSLOC)'="ALL"&('$D(ECSLOC(ECLOC))) Q ;126 Location check
- .I $G(ECSUNIT)'="ALL"&('$D(ECSUNIT(ECUNIT))) Q ;126 DSS Unit check
- .S ECLOCN=$$GET1^DIQ(4,ECLOC,.01) ;126 Get location name
- .S ECUNITN=$$GET1^DIQ(724,ECUNIT,.01) ;126 Get DSS Unit name
- .S ECPSY=+$O(^ECJ("AP",ECLOC,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="UNKNOWN"
- .S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0)),"^",5)),ECPXD=""
- .I ECCPT'="" D
- ..S ECPXD=$$CPT^ICPTCOD(ECCPT,$P(ECED,".")),ECCPT=$P(ECPXD,"^",2)_" "
- .I ECFILE=81 S ECPN=$S($P(ECPXD,"^",3)]"":$P(ECPXD,"^",3),1:"UNKNOWN")
- .I ECFILE=725 S EC725=$G(^EC(725,+ECP,0)),ECPN=$P(EC725,"^",2)_" "_$P(EC725,"^")
- .S ECEPN=$S(ECFILE=81:ECPN,1:$P(EC725,U))_$S(ECPSYN]"":" ["_ECPSYN_"]",1:"") ;119
- .S ECPTDS=ECCPT_ECPN_$S(ECPSYN]"":" ["_ECPSYN_"] ",1:"")
- .;Get Procedure CPT modifiers
- . K ECMOD S ECMODF=0 I $O(^ECH(DA,"MOD",0))'="" D
- ..S ECMODF=$$MOD^ECUTL(DA,"I",.ECMOD)
- ..;K ECMOD S ECMODF=$$MOD^ECUTL(DA,"I",.ECMOD)
- .;
- .;ALB/ESD - Get procedure reason from EC Patient file (#721) record
- .S ECPRSN="",ECLNK=+$P(EC,"^",23)
- .I +ECLNK>0 DO
- ..S ECPRSN=$P($G(^ECL(ECLNK,0)),"^",1)
- ..S:+ECPRSN'>0 ECPRSN="REASON NOT DEFINED"
- ..S:+ECPRSN>0 ECPRSN=$P(^ECR(ECPRSN,0),"^",1)
- .S:+ECLNK'>0 ECPRSN="REASON NOT DEFINED"
- .I '$D(ECRY) S ECPRSN="REASON NOT DEFINED"
- .;
- .;ALB/ESD - Add procedure reason to ^TMP array
- .S PRO=ECCPT_ECPN I PRO]"" S V=+$P(EC,"^",10) D
- ..F J=1:1:7 I A(J) S ^(J)=$G(^TMP("ECTMP",$J,ECLOCN,ECUNITN,PRO,ECPRSN,PA_"^"_SS,J))+V D ;126
- ...I $G(^TMP("ECTMP",$J,ECLOCN,ECUNITN,PRO))="" S ^TMP("ECTMP",$J,ECLOCN,ECUNITN,PRO)=ECPTDS ;126
- ..;ALB/JAM - Add Procedure CPT modifier to ^TMP array
- ..S MOD="" F S MOD=$O(ECMOD(MOD)) Q:MOD="" D
- ...S ^TMP("ECTMP",$J,ECLOCN,ECUNITN,PRO,ECPRSN,PA_"^"_SS,"MOD",MOD)=$G(^TMP("ECTMP",$J,ECLOCN,ECUNITN,PRO,ECPRSN,PA_"^"_SS,"MOD",MOD))+V ;126
- .I $G(ECPTYP)="E" S ^TMP("ECTMP",$J,ECLOCN,ECUNITN,PRO,ECPRSN,PA_U_SS,"EXPORT")=$P($G(ECCPT)," ")_U_$S(ECFILE=725:$P(EC725,U,2),1:"")_U_$G(ECEPN) ;119,126 additional information needed for export
- K ECLNK,MOD,ECPTDS
- I $G(ECPTYP)="E" D EXPORT,^ECKILL K ^TMP("ECTMP",$J) Q ;119 If exporting, process and then quit
- ;
- PRINT ;print report
- S ECSD=$P(ECDATE,"^"),ECED=$P(ECDATE,"^",2)
- I '$D(^TMP("ECTMP",$J)) S (ECLOC,ECUNIT)="" D HDR W !!,?12,"No Event Capture Provider Summary for "_ECUN_" to report for the date range selected.",!! D PAGE G END ;126
- S ECLOC="" F S ECLOC=$O(^TMP("ECTMP",$J,ECLOC)) Q:ECLOC="" D ;126
- .S ECUNIT="" F S ECUNIT=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT)) Q:ECUNIT="" D ;126
- ..;126 Code below modified for dot structure and correct array reference
- ..D HDR ;126 need header for each section
- ..F ECI=1:1:7 S A(ECI)=0
- ..S (ECREAS,PA,PR)=""
- ..F S PR=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR)),PA="" Q:PR="" D Q:ECOUT
- ...W !,^TMP("ECTMP",$J,ECLOC,ECUNIT,PR)
- ...F S ECREAS=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS)) Q:ECREAS="" D Q:ECOUT
- ....F S PA=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA)) D:PA="" TOT Q:PA="" D Q:ECOUT
- .....S A=$G(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA,0))
- .....W ! W:$D(ECRY) $E(ECREAS,1,23)
- .....W ?25,$E($P(PA,"^"),1,24),?52,$E($P(PA,"^",2),6,9) ;112 only print last 4
- .....F J=1:1:7 S A=$G(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA,J)),A(J)=A(J)+A W ?10*J+50,$J(A,5,0) I J=7 I $Y+8>IOSL D PAGE Q:ECOUT D HDR
- .....;print CPT procedure modifiers
- .....Q:ECOUT S IEN=""
- .....F S IEN=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA,"MOD",IEN)) Q:IEN="" D I ECOUT Q
- ......S MODI=$$MOD^ICPTMOD(IEN,"I",$P(ECED,"."))
- ......S MOD=$P(MODI,U,2) I MOD="" Q
- ......S MODESC=$P(MODI,U,3) I MODESC="" S MODESC="UNKNOWN"
- ......S MODAMT=^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA,"MOD",IEN)
- ......W !?5,"- ",MOD," ",MODESC," (",MODAMT,")"
- ......I ($Y+7)>IOSL D PAGE Q:ECOUT D HDR
- .....K MODESC,MOD,MODAMT
- W !!,?60 F RK=61:1:IOM W "*"
- W !,?35,"GRAND TOTAL - PROCEDURES"
- F J=1:1:7 W ?10*J+50,$J(ECGT(J),5,0)
- D:'ECOUT PAGE G END
- ;
- PAGE ; end of page
- D FOOTER
- I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECOUT=1
- Q
- HDR ;
- W:$Y @IOF S ECPG=ECPG+1
- W !!?33,"EVENT CAPTURE PROVIDER (1-7) SUMMARY FOR ",ECUN,?118,"Page: ",ECPG,!,?33,"LOCATION: ",$G(ECLOC),!,?33,"DSS UNIT: ",$G(ECUNIT) ;112,126
- W !,?33,"FOR THE DATE RANGE ",$$FMTE^XLFDT(ECSD)," TO ",$$FMTE^XLFDT(ECED),!!,"PROCEDURE",?85,"TOTALS AS PROVIDER #",! ;112,126
- W:$D(ECRY) "PROCEDURE REASON" W ?25,"PATIENT",?52,"SSN",?64,1,?74,2,?84,3,?94,4,?104,5,?114,6,?124,7
- W !,?5,"CPT MODIFIER (Volume of modifiers used)",! ;126 fixed spelling error
- F RK=1:1:IOM W "-"
- W !
- Q
- ;
- TOT W !,?60 F RK=61:1:IOM W "-"
- W !?35,"TOTAL PROCEDURES"
- F J=1:1:7 W ?10*J+50,$J(A(J),5,0) S ECGT(J)=ECGT(J)+A(J)
- W ! F ECI=1:1:7 S A(ECI)=0
- Q
- ;
- W !!?4,"Volume totals may represent days, minutes, numbers of procedures"
- W " and/or a combination of these." ;126 Combined lines for report
- Q
- ;
- END D ^ECKILL K ^TMP("ECTMP",$J),ZTSK W @IOF
- K ^TMP("ECTMP",$J) Q:$D(ECGUI)
- I $D(ZTQUEUED) S ZTREQ="@"
- D ^%ZISC
- Q
- ;
- EXPORT ;Section added in 119
- N CNT,ECI,A,PA,PR,ECREAS,EXPORT,SUB,MODCNT,MODI,MOD,MODESC,MODAMT,ECLOC,ECUNIT ;126
- S CNT=1
- S ^TMP($J,"ECRPT",CNT)="PROVIDER NAME^LOCATION^DSS UNIT^CPT CODE^CPT MOD #1 (VOL)^CPT MOD #2 (VOL)^CPT MOD #3 (VOL)^PROCEDURE CODE^PROCEDURE NAME^PATIENT^SSN" ;126
- S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_"^TOTAL AS PROV #1^TOTAL AS PROV #2^TOTAL AS PROV #3^TOTAL AS PROV #4^TOTAL AS PROV #5^TOTAL AS PROV #6^TOTAL AS PROV #7" ;126
- S ECLOC="" F S ECLOC=$O(^TMP("ECTMP",$J,ECLOC)) Q:ECLOC="" D ;126
- .S ECUNIT="" F S ECUNIT=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT)) Q:ECUNIT="" D ;126
- ..;126 Section modified for dot structure and array levels
- ..S (ECREAS,PA,PR)=""
- ..F S PR=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR)),PA="" Q:PR="" D
- ...F S ECREAS=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS)) Q:ECREAS="" D
- ....F S PA=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA)) Q:PA="" D
- .....S EXPORT=^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA,"EXPORT")
- .....S CNT=CNT+1
- .....S ^TMP($J,"ECRPT",CNT)=ECUN_U_ECLOC_U_ECUNIT_U_$P(EXPORT,U) ;126
- .....S SUB=0,MODCNT=0 F S:SUB'="" SUB=$O(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA,"MOD",SUB)) Q:MODCNT=3 D S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_U_MOD,MODCNT=MODCNT+1 ;126
- ......S MOD="" I SUB="" Q ;126
- ......S MODI=$$MOD^ICPTMOD(SUB,"I",$P(ECED,".")) S MOD=$P(MODI,U,2) Q:MOD="" S MODESC=$S($P(MODI,U,3)="":"UNKNOWN",1:$P(MODI,U,3)),MODAMT=^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA,"MOD",SUB) ;126
- ......S MOD=MOD_" "_MODESC_" ("_MODAMT_")" ;126
- .....S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_U_$P(EXPORT,U,2)_U_$P(EXPORT,U,3)_U_$P(PA,U)_U_$E($P(PA,U,2),6,9) ;126
- .....F J=1:1:7 S $P(^TMP($J,"ECRPT",CNT),U,(J+11))=+$G(^TMP("ECTMP",$J,ECLOC,ECUNIT,PR,ECREAS,PA,J)) ;126
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECPRSUM1 9223 printed Feb 18, 2025@23:24:50 Page 2
- ECPRSUM1 ;BIR/DMA,RHK,JPW - Provider Summary (1 to 7) ;12/2/14 11:09
- +1 ;;2.0;EVENT CAPTURE;**5,18,33,47,62,63,61,72,88,95,112,119,126**;8 May 96;Build 8
- +2 ;In patch 119, temporary data storage for the report was moved from
- +3 ;^TMP($J to ^TMP("ECTMP",$J so that the exportable version of the
- +4 ;report, which is returned in ^TMP($J,"ECRPT", wouldn't be deleted upon
- +5 ;completion. That change occurred in many lines in this routine.
- +6 ;
- +7 SET DIC=200
- SET DIC(0)="AQEMZ"
- SET DIC("A")="Select Provider: "
- +8 DO ^DIC
- KILL DIC
- if Y<0
- GOTO END
- SET ECU=+Y
- SET ECUN=$PIECE(Y,"^",2)
- +9 ;D REASON^ECRUTL ;* Prompt to include Procedure Reasons. 112, Remove reasons from report
- +10 IF ($DATA(DIRUT))!($DATA(DUOUT))
- GOTO END
- BDATE KILL %DT
- SET %DT="AEX"
- SET %DT("A")="Starting with Date: "
- +1 DO ^%DT
- if Y<0
- GOTO END
- SET ECSD=Y
- EDATE KILL %DT
- SET %DT="AEX"
- SET %DT("A")="Ending with Date: "
- DO ^%DT
- if Y<0
- GOTO END
- +1 IF Y<ECSD
- Begin DoDot:1
- +2 WRITE !!,"The ending date cannot be earlier than the starting date. "
- +3 WRITE "Please re-enter",!,"the ending date.",!
- End DoDot:1
- GOTO EDATE
- +4 SET ECED=Y
- SET ECDATE=ECSD_"^"_ECED
- DEV ;dev call
- +1 WRITE !!,"This report is formatted for 132 column output.",!!
- +2 SET %ZIS="Q"
- SET %ZIS("A")="Select Device: "
- DO ^%ZIS
- if POP
- GOTO END
- +3 IF $DATA(IO("Q"))
- KILL ZTSAVE
- SET (ZTSAVE("ECRY"),ZTSAVE("ECSD"),ZTSAVE("ECDATE"),ZTSAVE("ECED"),ZTSAVE("ECU"),ZTSAVE("ECUN"))=""
- SET ZTDESC="Event Capture Provider Summary"
- SET ZTRTN="EN^ECPRSUM1"
- DO ^%ZTLOAD
- DO HOME^%ZIS
- KILL ZTSK
- GOTO END
- +4 ;
- EN ;QUEUED ENTRY POINT
- +1 ;119,126
- NEW ECPG,ECGT,EC,ECCAT,ECPXD,MODI,ECI,ECPRV,RK,A,ECX,EC725,ECEPN,ECLOCN,ECUNITN
- +2 ;119 Only need IO if not exporting
- IF $GET(ECPTYP)'="E"
- USE IO
- +3 SET (ECOUT,ECPG)=0
- FOR ECI=1:1:7
- SET ECGT(ECI)=0
- SET A(ECI)=0
- +4 KILL ^TMP("ECTMP",$JOB)
- SET ECOUT=0
- SET ECSD=ECSD-.1
- SET ECED=ECED+.3
- +5 FOR ECD=ECSD:0
- SET ECD=$ORDER(^ECH("AC",ECD))
- if 'ECD
- QUIT
- if ECD>ECED
- QUIT
- FOR DA=0:0
- SET DA=$ORDER(^ECH("AC",ECD,DA))
- if 'DA
- QUIT
- IF $DATA(^ECH("APRV",ECU,DA))
- SET EC=$GET(^ECH(DA,0))
- Begin DoDot:1
- +6 KILL ECPRV
- SET ECPRV=$$GETPRV^ECPRVMUT(DA,.ECPRV)
- SET ECX=0
- IF ECPRV
- QUIT
- +7 FOR ECI=1:1:7
- SET A(ECI)=0
- +8 FOR ECI=1:1:7
- SET ECX=$ORDER(ECPRV(ECX))
- if 'ECX
- QUIT
- Begin DoDot:2
- +9 SET A(ECI)=$PIECE(ECPRV(ECX),U)=ECU
- End DoDot:2
- +10 SET ECX=A(1)=A(2)=A(3)=A(4)=A(5)=A(6)=A(7)
- IF 'ECX
- QUIT
- +11 SET ECPAT=+$PIECE(EC,"^",2)
- SET PA=$GET(^DPT(ECPAT,0))
- SET SS=$PIECE(PA,"^",9)
- +12 SET PA=$SELECT($PIECE(PA,"^")]"":$PIECE(PA,"^"),1:"UNKNOWN")
- SET ECP=$PIECE(EC,"^",9)
- +13 if ECP']""
- QUIT
- +14 SET ECLOC=+$PIECE(EC,U,4)
- SET ECUNIT=+$PIECE(EC,U,7)
- SET ECCAT=+$PIECE(EC,U,8)
- +15 ;126 Location check
- IF $GET(ECSLOC)'="ALL"&('$DATA(ECSLOC(ECLOC)))
- QUIT
- +16 ;126 DSS Unit check
- IF $GET(ECSUNIT)'="ALL"&('$DATA(ECSUNIT(ECUNIT)))
- QUIT
- +17 ;126 Get location name
- SET ECLOCN=$$GET1^DIQ(4,ECLOC,.01)
- +18 ;126 Get DSS Unit name
- SET ECUNITN=$$GET1^DIQ(724,ECUNIT,.01)
- +19 SET ECPSY=+$ORDER(^ECJ("AP",ECLOC,ECUNIT,ECCAT,ECP,""))
- +20 SET ECPSYN=$PIECE($GET(^ECJ(ECPSY,"PRO")),"^",2)
- +21 SET ECFILE=$PIECE(ECP,";",2)
- SET ECFILE=$SELECT($EXTRACT(ECFILE)="I":81,$EXTRACT(ECFILE)="E":725,1:"UNKNOWN")
- +22 IF ECFILE="UNKNOWN"
- SET ECPN="UNKNOWN"
- +23 SET ECCPT=$SELECT(ECFILE=81:+ECP,1:$PIECE($GET(^EC(725,+ECP,0)),"^",5))
- SET ECPXD=""
- +24 IF ECCPT'=""
- Begin DoDot:2
- +25 SET ECPXD=$$CPT^ICPTCOD(ECCPT,$PIECE(ECED,"."))
- SET ECCPT=$PIECE(ECPXD,"^",2)_" "
- End DoDot:2
- +26 IF ECFILE=81
- SET ECPN=$SELECT($PIECE(ECPXD,"^",3)]"":$PIECE(ECPXD,"^",3),1:"UNKNOWN")
- +27 IF ECFILE=725
- SET EC725=$GET(^EC(725,+ECP,0))
- SET ECPN=$PIECE(EC725,"^",2)_" "_$PIECE(EC725,"^")
- +28 ;119
- SET ECEPN=$SELECT(ECFILE=81:ECPN,1:$PIECE(EC725,U))_$SELECT(ECPSYN]"":" ["_ECPSYN_"]",1:"")
- +29 SET ECPTDS=ECCPT_ECPN_$SELECT(ECPSYN]"":" ["_ECPSYN_"] ",1:"")
- +30 ;Get Procedure CPT modifiers
- +31 KILL ECMOD
- SET ECMODF=0
- IF $ORDER(^ECH(DA,"MOD",0))'=""
- Begin DoDot:2
- +32 SET ECMODF=$$MOD^ECUTL(DA,"I",.ECMOD)
- +33 ;K ECMOD S ECMODF=$$MOD^ECUTL(DA,"I",.ECMOD)
- End DoDot:2
- +34 ;
- +35 ;ALB/ESD - Get procedure reason from EC Patient file (#721) record
- +36 SET ECPRSN=""
- SET ECLNK=+$PIECE(EC,"^",23)
- +37 IF +ECLNK>0
- Begin DoDot:2
- +38 SET ECPRSN=$PIECE($GET(^ECL(ECLNK,0)),"^",1)
- +39 if +ECPRSN'>0
- SET ECPRSN="REASON NOT DEFINED"
- +40 if +ECPRSN>0
- SET ECPRSN=$PIECE(^ECR(ECPRSN,0),"^",1)
- End DoDot:2
- +41 if +ECLNK'>0
- SET ECPRSN="REASON NOT DEFINED"
- +42 IF '$DATA(ECRY)
- SET ECPRSN="REASON NOT DEFINED"
- +43 ;
- +44 ;ALB/ESD - Add procedure reason to ^TMP array
- +45 SET PRO=ECCPT_ECPN
- IF PRO]""
- SET V=+$PIECE(EC,"^",10)
- Begin DoDot:2
- +46 ;126
- FOR J=1:1:7
- IF A(J)
- SET ^(J)=$GET(^TMP("ECTMP",$JOB,ECLOCN,ECUNITN,PRO,ECPRSN,PA_"^"_SS,J))+V
- Begin DoDot:3
- +47 ;126
- IF $GET(^TMP("ECTMP",$JOB,ECLOCN,ECUNITN,PRO))=""
- SET ^TMP("ECTMP",$JOB,ECLOCN,ECUNITN,PRO)=ECPTDS
- End DoDot:3
- +48 ;ALB/JAM - Add Procedure CPT modifier to ^TMP array
- +49 SET MOD=""
- FOR
- SET MOD=$ORDER(ECMOD(MOD))
- if MOD=""
- QUIT
- Begin DoDot:3
- +50 ;126
- SET ^TMP("ECTMP",$JOB,ECLOCN,ECUNITN,PRO,ECPRSN,PA_"^"_SS,"MOD",MOD)=$GET(^TMP("ECTMP",$JOB,ECLOCN,ECUNITN,PRO,ECPRSN,PA_"^"_SS,"MOD",MOD))+V
- End DoDot:3
- End DoDot:2
- +51 ;119,126 additional information needed for export
- IF $GET(ECPTYP)="E"
- SET ^TMP("ECTMP",$JOB,ECLOCN,ECUNITN,PRO,ECPRSN,PA_U_SS,"EXPORT")=$PIECE($GET(ECCPT)," ")_U_$SELECT(ECFILE=725:$PIECE(EC725,U,2),1:"")_U_$GET(ECEPN)
- End DoDot:1
- +52 KILL ECLNK,MOD,ECPTDS
- +53 ;119 If exporting, process and then quit
- IF $GET(ECPTYP)="E"
- DO EXPORT
- DO ^ECKILL
- KILL ^TMP("ECTMP",$JOB)
- QUIT
- +54 ;
- PRINT ;print report
- +1 SET ECSD=$PIECE(ECDATE,"^")
- SET ECED=$PIECE(ECDATE,"^",2)
- +2 ;126
- IF '$DATA(^TMP("ECTMP",$JOB))
- SET (ECLOC,ECUNIT)=""
- DO HDR
- WRITE !!,?12,"No Event Capture Provider Summary for "_ECUN_" to report for the date range selected.",!!
- DO PAGE
- GOTO END
- +3 ;126
- SET ECLOC=""
- FOR
- SET ECLOC=$ORDER(^TMP("ECTMP",$JOB,ECLOC))
- if ECLOC=""
- QUIT
- Begin DoDot:1
- +4 ;126
- SET ECUNIT=""
- FOR
- SET ECUNIT=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT))
- if ECUNIT=""
- QUIT
- Begin DoDot:2
- +5 ;126 Code below modified for dot structure and correct array reference
- +6 ;126 need header for each section
- DO HDR
- +7 FOR ECI=1:1:7
- SET A(ECI)=0
- +8 SET (ECREAS,PA,PR)=""
- +9 FOR
- SET PR=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR))
- SET PA=""
- if PR=""
- QUIT
- Begin DoDot:3
- +10 WRITE !,^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR)
- +11 FOR
- SET ECREAS=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS))
- if ECREAS=""
- QUIT
- Begin DoDot:4
- +12 FOR
- SET PA=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA))
- if PA=""
- DO TOT
- if PA=""
- QUIT
- Begin DoDot:5
- +13 SET A=$GET(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA,0))
- +14 WRITE !
- if $DATA(ECRY)
- WRITE $EXTRACT(ECREAS,1,23)
- +15 ;112 only print last 4
- WRITE ?25,$EXTRACT($PIECE(PA,"^"),1,24),?52,$EXTRACT($PIECE(PA,"^",2),6,9)
- +16 FOR J=1:1:7
- SET A=$GET(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA,J))
- SET A(J)=A(J)+A
- WRITE ?10*J+50,$JUSTIFY(A,5,0)
- IF J=7
- IF $Y+8>IOSL
- DO PAGE
- if ECOUT
- QUIT
- DO HDR
- +17 ;print CPT procedure modifiers
- +18 if ECOUT
- QUIT
- SET IEN=""
- +19 FOR
- SET IEN=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA,"MOD",IEN))
- if IEN=""
- QUIT
- Begin DoDot:6
- +20 SET MODI=$$MOD^ICPTMOD(IEN,"I",$PIECE(ECED,"."))
- +21 SET MOD=$PIECE(MODI,U,2)
- IF MOD=""
- QUIT
- +22 SET MODESC=$PIECE(MODI,U,3)
- IF MODESC=""
- SET MODESC="UNKNOWN"
- +23 SET MODAMT=^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA,"MOD",IEN)
- +24 WRITE !?5,"- ",MOD," ",MODESC," (",MODAMT,")"
- +25 IF ($Y+7)>IOSL
- DO PAGE
- if ECOUT
- QUIT
- DO HDR
- End DoDot:6
- IF ECOUT
- QUIT
- +26 KILL MODESC,MOD,MODAMT
- End DoDot:5
- if ECOUT
- QUIT
- End DoDot:4
- if ECOUT
- QUIT
- End DoDot:3
- if ECOUT
- QUIT
- End DoDot:2
- End DoDot:1
- +27 WRITE !!,?60
- FOR RK=61:1:IOM
- WRITE "*"
- +28 WRITE !,?35,"GRAND TOTAL - PROCEDURES"
- +29 FOR J=1:1:7
- WRITE ?10*J+50,$JUSTIFY(ECGT(J),5,0)
- +30 if 'ECOUT
- DO PAGE
- GOTO END
- +31 ;
- PAGE ; end of page
- +1 DO FOOTER
- +2 IF $EXTRACT(IOST,1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET ECOUT=1
- +3 QUIT
- HDR ;
- +1 if $Y
- WRITE @IOF
- SET ECPG=ECPG+1
- +2 ;112,126
- WRITE !!?33,"EVENT CAPTURE PROVIDER (1-7) SUMMARY FOR ",ECUN,?118,"Page: ",ECPG,!,?33,"LOCATION: ",$GET(ECLOC),!,?33,"DSS UNIT: ",$GET(ECUNIT)
- +3 ;112,126
- WRITE !,?33,"FOR THE DATE RANGE ",$$FMTE^XLFDT(ECSD)," TO ",$$FMTE^XLFDT(ECED),!!,"PROCEDURE",?85,"TOTALS AS PROVIDER #",!
- +4 if $DATA(ECRY)
- WRITE "PROCEDURE REASON"
- WRITE ?25,"PATIENT",?52,"SSN",?64,1,?74,2,?84,3,?94,4,?104,5,?114,6,?124,7
- +5 ;126 fixed spelling error
- WRITE !,?5,"CPT MODIFIER (Volume of modifiers used)",!
- +6 FOR RK=1:1:IOM
- WRITE "-"
- +7 WRITE !
- +8 QUIT
- +9 ;
- TOT WRITE !,?60
- FOR RK=61:1:IOM
- WRITE "-"
- +1 WRITE !?35,"TOTAL PROCEDURES"
- +2 FOR J=1:1:7
- WRITE ?10*J+50,$JUSTIFY(A(J),5,0)
- SET ECGT(J)=ECGT(J)+A(J)
- +3 WRITE !
- FOR ECI=1:1:7
- SET A(ECI)=0
- +4 QUIT
- +5 ;
- +1 WRITE !!?4,"Volume totals may represent days, minutes, numbers of procedures"
- +2 ;126 Combined lines for report
- WRITE " and/or a combination of these."
- +3 QUIT
- +4 ;
- END DO ^ECKILL
- KILL ^TMP("ECTMP",$JOB),ZTSK
- WRITE @IOF
- +1 KILL ^TMP("ECTMP",$JOB)
- if $DATA(ECGUI)
- QUIT
- +2 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 DO ^%ZISC
- +4 QUIT
- +5 ;
- EXPORT ;Section added in 119
- +1 ;126
- NEW CNT,ECI,A,PA,PR,ECREAS,EXPORT,SUB,MODCNT,MODI,MOD,MODESC,MODAMT,ECLOC,ECUNIT
- +2 SET CNT=1
- +3 ;126
- SET ^TMP($JOB,"ECRPT",CNT)="PROVIDER NAME^LOCATION^DSS UNIT^CPT CODE^CPT MOD #1 (VOL)^CPT MOD #2 (VOL)^CPT MOD #3 (VOL)^PROCEDURE CODE^PROCEDURE NAME^PATIENT^SSN"
- +4 ;126
- SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_"^TOTAL AS PROV #1^TOTAL AS PROV #2^TOTAL AS PROV #3^TOTAL AS PROV #4^TOTAL AS PROV #5^TOTAL AS PROV #6^TOTAL AS PROV #7"
- +5 ;126
- SET ECLOC=""
- FOR
- SET ECLOC=$ORDER(^TMP("ECTMP",$JOB,ECLOC))
- if ECLOC=""
- QUIT
- Begin DoDot:1
- +6 ;126
- SET ECUNIT=""
- FOR
- SET ECUNIT=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT))
- if ECUNIT=""
- QUIT
- Begin DoDot:2
- +7 ;126 Section modified for dot structure and array levels
- +8 SET (ECREAS,PA,PR)=""
- +9 FOR
- SET PR=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR))
- SET PA=""
- if PR=""
- QUIT
- Begin DoDot:3
- +10 FOR
- SET ECREAS=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS))
- if ECREAS=""
- QUIT
- Begin DoDot:4
- +11 FOR
- SET PA=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA))
- if PA=""
- QUIT
- Begin DoDot:5
- +12 SET EXPORT=^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA,"EXPORT")
- +13 SET CNT=CNT+1
- +14 ;126
- SET ^TMP($JOB,"ECRPT",CNT)=ECUN_U_ECLOC_U_ECUNIT_U_$PIECE(EXPORT,U)
- +15 ;126
- SET SUB=0
- SET MODCNT=0
- FOR
- if SUB'=""
- SET SUB=$ORDER(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA,"MOD",SUB))
- if MODCNT=3
- QUIT
- Begin DoDot:6
- +16 ;126
- SET MOD=""
- IF SUB=""
- QUIT
- +17 ;126
- SET MODI=$$MOD^ICPTMOD(SUB,"I",$PIECE(ECED,"."))
- SET MOD=$PIECE(MODI,U,2)
- if MOD=""
- QUIT
- SET MODESC=$SELECT($PIECE(MODI,U,3)="":"UNKNOWN",1:$PIECE(MODI,U,3))
- SET MODAMT=^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA,"MOD",SUB)
- +18 ;126
- SET MOD=MOD_" "_MODESC_" ("_MODAMT_")"
- End DoDot:6
- SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_U_MOD
- SET MODCNT=MODCNT+1
- +19 ;126
- SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_U_$PIECE(EXPORT,U,2)_U_$PIECE(EXPORT,U,3)_U_$PIECE(PA,U)_U_$EXTRACT($PIECE(PA,U,2),6,9)
- +20 ;126
- FOR J=1:1:7
- SET $PIECE(^TMP($JOB,"ECRPT",CNT),U,(J+11))=+$GET(^TMP("ECTMP",$JOB,ECLOC,ECUNIT,PR,ECREAS,PA,J))
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 QUIT
