- ECPROV3 ;BIR/MAM,JPW - Event Capture Provider Summary (cont'd) ;11/20/12 13:49
- ;;2.0;EVENT CAPTURE;**5,8,18,29,47,56,63,72,95,112,119**;8 May 96;Build 12
- ; This routine is used when printing the report for
- ; all ACCESSIBLE DSS Units
- ;JAM/3/7/03, This routine now combines ECPROV3, ECPROV4 and ECPROV5
- ;
- ;119 Changed all ^TMP($J references to ^TMP("ECTMP",$J so that temporary storage doesn't conflict with exporting data in ^TMP($J
- N %H ;112
- S %H=$H D YX^%DTC S ECRDT=Y
- I ECL D D LOC D:$G(ECPTYP)="E" EXPORT D:$G(ECPTYP)'="E" PRINT Q ;119 Q
- .I ECPRV=1 D UNIT Q
- .I 'ECPRV S ECC=+$P(^ECD(ECD,0),U,11) Q
- S ECL=0 D
- .F I=0:0 S ECL=$O(^ECH("ADT",ECL)) Q:'ECL D
- ..S ECLN=$P(^DIC(4,ECL,0),"^") I ECPRV D UNIT
- ..I 'ECPRV S ECC=+$P(^ECD(ECD,0),U,11)
- ..D LOC
- I $G(ECPTYP)="E" D EXPORT Q ;119
- PRINT ;Changes below were made by VMP to correct NOIS ATG-1003-32545
- S (ECLN,ECPN)=0,ECCN=""
- F I=0:0 S ECLN=$O(^TMP("ECTMP",$J,ECLN)) Q:ECLN=""!(ECOUT)!(ECLN["^") D
- .I 'ECPRV D CATS Q
- . S ECDN="" D NOUNIT F I=0:0 S ECDN=$O(^TMP("ECTMP",$J,ECLN,ECDN)) Q:ECDN=""!(ECOUT) D CATS
- K ECPNAM
- D FOOTER ;print footer on last page
- Q
- CATS ; continue looping
- I $O(^TMP("ECTMP",$J,ECLN,ECDN,""))']"" D PAGE W !!!,?12,"NO PROCEDURES" S ECPG=1 Q
- D PAGE Q:ECOUT S ECPG=1,ECUN=0 F I=0:0 S ECUN=$O(^TMP("ECTMP",$J,ECLN,ECDN,ECUN)) Q:ECUN=""!(ECOUT) S ECINZ="^"_$O(^(ECUN,0)) D:$Y+10>IOSL PAGE Q:ECOUT D PRO
- Q
- PRO I $Y+13>IOSL D PAGE I ECOUT Q
- W !!,ECUN S ECCN=0 F I=0:0 S ECCN=$O(^TMP("ECTMP",$J,ECINZ,ECCN)) D:ECCN="" TOTP Q:ECCN=""!(ECOUT) D MORE
- Q
- MORE ;
- ;ALB/ESD - Loop through to get procedure reason and print
- W !,?3,ECCN S ECPN=0,(ECPRSN,ECPI)=""
- F S ECPN=$O(^TMP("ECTMP",$J,ECINZ,ECCN,ECPN)) Q:ECPN=""!(ECOUT) S ECUSER=1 D:$Y+10>IOSL PAGE Q:ECOUT K ECUSER F S ECPRSN=$O(^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN)) Q:ECPRSN=""!(ECOUT) DO
- .S ECCPT=$S($P(ECPN,"~",3)="I":$P(ECPN,"~",2),1:$P($G(^EC(725,$P(ECPN,"~",2),0)),"^",5))
- .I ECCPT'="" D
- ..;Changes made by VMP to correct NOIS ATG-1003-32545
- ..;use end date/date range to get CPT description; CTD project.
- ..S ECPI=$$CPT^ICPTCOD(ECCPT,$P(ECED,".")),ECCPT=$P(ECPI,"^",2)
- .S EC725="" I $P(ECPN,"~",3)="E" S EC725=$G(^EC(725,+$P(ECPN,"~",2),0))
- .S ECPNAM=$S($P(ECPN,"~",3)="E":$P(EC725,"^"),$P(ECPN,"~",3)="I":$P(ECPI,"^",3),1:"UNKNOWN") ;112
- .S ECPSY=$P(ECPN,"~",4),ECPSYN=""
- .I ECPSY'="" S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2)
- .W !,?6,$J(ECCPT_" ",6),$J($S($P($G(EC725),"^",2)="":ECCPT_" ",1:$P($G(EC725),"^",2)_" "),6),?18,$E(ECPNAM,1,40) ;112
- .W:ECPSYN'="" " [",$E(ECPSYN,1,25),"]"
- .W:$D(ECRY) ?70,ECPRSN
- .W ?105,$J(^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN),6)
- .;print CPT procedure modifiers
- .S IEN=""
- .F S IEN=$O(^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",IEN)) Q:IEN="" D I ECOUT Q
- ..;used end date to get description,CTD project
- ..S MODI=$$MOD^ICPTMOD(IEN,"I",$P(ECED,"."))
- ..S MOD=$P(MODI,"^",2) I MOD="" K MODI Q
- ..S MODESC=$P(MODI,"^",3) I MODESC="" S MODESC="UNKNOWN"
- ..S MODAMT=^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",IEN)
- ..W !?10,"- ",MOD," ",MODESC," (",MODAMT,")"
- ..I ($Y+6)>IOSL D PAGE
- .K MODESC,MOD,IEN,MODAMT,MODI,EC725
- Q
- LOC S (ECDFN,ECOUT,^TMP("ECTMP",$J,ECLN))=0
- F I=0:0 S ECDFN=$O(^ECH("ADT",ECL,ECDFN)) Q:'ECDFN D
- .I ECPRV D GECD Q
- .D GMM
- Q
- GECD S ECD=0 F I=0:0 S ECD=$O(^ECH("ADT",ECL,ECDFN,ECD)) Q:'ECD D GMM
- Q
- GMM S MM=ECSD F I=0:0 S MM=$O(^ECH("ADT",ECL,ECDFN,ECD,MM)) Q:'MM!(MM>ECED) D LOC1
- Q
- LOC1 S ECFN=0 F I=0:0 S ECFN=$O(^ECH("ADT",ECL,ECDFN,ECD,MM,ECFN)) Q:'ECFN D UTL
- Q
- UTL ; set ^TMP("ECTMP",$J
- Q:'$D(^ECH(+ECFN,0))!(+$G(ECD)'=$P($G(^ECH(+ECFN,0)),"^",7))
- S ECEC=^ECH(+ECFN,0),ECV=+$P(ECEC,"^",10),ECC=+$P(ECEC,"^",8)
- ;S ECP=$P(ECEC,"^",9),ECU=+$P(ECEC,"^",11)
- S ECP=$P(ECEC,"^",9),ECU=$$GETPPRV^ECPRVMUT(ECFN,.ECUN),ECUN=$S(ECU:"UNKNOWN",1:$P(ECUN,"^",2))
- S ECCN=$S($P($G(^EC(726,ECC,0)),"^")]"":$P(^(0),"^"),1:"None")
- Q:ECP']""
- S ECD=+$P(ECEC,"^",7)
- I ECPRV=1 Q:'$D(ECDU(ECD)) S ECDN=ECDU(ECD)
- I ECPRV=2 S ECDN=$S($P($G(^ECD(ECD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- ;S ECUN=$S($P($G(^VA(200,ECU,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- S ECPSY=+$O(^ECJ("AP",ECL,ECD,ECC,ECP,"")),ECPN=""
- S ECFILE=$P(ECP,";",2),ECFILE=$S($E(ECFILE)="I":81,$E(ECFILE)="E":725,1:"UNKNOWN")
- I ECFILE=81 S ECPN=$P($$CPT^ICPTCOD(+ECP,$P(ECED,".")),"^",3)
- I ECFILE=725 S ECPN=$P($G(^EC(725,+ECP,0)),"^")
- I ECFILE="UNKNOWN"!(ECPN="") S ECPN="UNKNOWN"
- ;Changes made by VMP to correct NOIS SDC-1003-60397
- S ECPN=$E(ECPN,1,5)_"~"_$P(ECP,";")_"~"_$E($P(ECP,";",2))_"~"_ECPSY
- ;Get Procedure CPT modifiers
- S ECMODF=0 K ECMOD
- I $O(^ECH(+ECFN,"MOD",0))'="" S ECMODF=$$MOD^ECUTL(+ECFN,"I",.ECMOD)
- ;
- ;ALB/ESD - Get procedure reason from EC Patient file (#721) record
- N ECLNK
- S ECPRSN=""
- S ECLNK=+$P(ECEC,"^",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" ;group proc reason-not print
- I '$D(^TMP("ECTMP",$J,ECLN,ECDN,ECUN)) S ECINC=ECINC+1,ECINZ="^"_ECINC,^(ECUN)=0,^(ECUN,ECINC)=0
- S ECINZ="^"_$O(^TMP("ECTMP",$J,ECLN,ECDN,ECUN,0))
- I '$D(^TMP("ECTMP",$J,ECINZ,ECCN)) S ^TMP("ECTMP",$J,ECINZ,ECCN)=0
- ;
- ;ALB/ESD - Add procedure reason to ^TMP array
- I '$D(^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN)) S ^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN)=0
- S ^TMP("ECTMP",$J,ECLN)=^TMP("ECTMP",$J,ECLN)+ECV
- S ^TMP("ECTMP",$J,ECLN,ECDN,ECUN)=^TMP("ECTMP",$J,ECLN,ECDN,ECUN)+ECV
- S ^TMP("ECTMP",$J,ECINZ,ECCN)=^TMP("ECTMP",$J,ECINZ,ECCN)+ECV
- ;
- ;ALB/ESD - Add procedure reason to ^TMP array
- S ^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN)=^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN)+ECV
- ;ALB/JAM - Add Procedure CPT modifier to ^TMP array
- S MOD="" F S MOD=$O(ECMOD(MOD)) Q:MOD="" D
- . S ^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD)=$G(^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD))+ECV
- Q
- PAGE ; end of page
- D:$D(ECPG) FOOTER
- I $D(ECPG),$E(IOST,1,2)="C-" W !!,"Press <RET> to continue, or ^ to quit " R X:DTIME I '$T!(X="^") S ECOUT=1 Q
- HDR ; print heading
- W:$Y @IOF W !!,?49,"EVENT CAPTURE PROVIDER SUMMARY",!,?49,"FROM "_$P(ECDATE,"^")_" TO "_$P(ECDATE,"^",2),!,?49,"Run Date : ",ECRDT
- W !!?3,"Category",?105,"Procedure/Reason",!,?6,"CPT",?12,"Proc",?18,"Procedure Name" ;112
- W:$D(ECRY) ?70,"Procedure Reason #1" ;112
- W ?105,"Volume*",!,?6,"Code",?12,"Code",!,?10,"CPT Modifier (volume)",! ;112
- F LINE=1:1:132 W "-"
- W !!,"Location: "_ECLN,! W:ECDN]"" "DSS Unit: "_ECDN
- I ECPRV,$D(ECUSER) W !!,ECUN,!,ECCN
- Q
- W !!?4,"*Volume totals may represent days, minutes, numbers of procedures and/or a combination of these."
- I $G(ECRY)'="" W !?4,"Procedure/Reason Volume = count of unique combinations of procedure code and procedure reason" ;112
- Q
- ;
- TOTP Q:ECOUT W !,?105,"------",!,"Total Procedures for "_ECUN,?105,$J(^TMP("ECTMP",$J,ECLN,ECDN,ECUN),6)
- Q
- UNIT ; set units
- S CNT=0 F I=0:0 S CNT=$O(UNIT(CNT)) Q:'CNT S ECDU(+UNIT(CNT))=$P(UNIT(CNT),"^",2)
- Q
- ;
- NOUNIT ;Nothing there
- I $O(^TMP("ECTMP",$J,ECLN,ECDN))']"" D PAGE W !!!,?12,"NO PROCEDURES",! S ECPG=1
- Q
- ;
- EXPORT ;119 Entire section added in patch 119 for exporting data to excel
- N CNT,ECLN,ECPN,ECCN,I,ECDN,ECINZ,ECUN,ECPRSN,ECPI,ECCPT,EC725,ECPNAM,ECPSY,ECPSYN,MOD1,VOL1,MOD2,VOL2,MOD3,VOL3
- S CNT=1,^TMP($J,"ECRPT",CNT)="LOCATION^DSS UNIT^CATEGORY^PROVIDER^CPT CODE^PROCEDURE CODE^PROCEDURE NAME^PROCEDURE REASON#1^PROCEDURE/REASON VOLUME^CPT MOD 1^CPT MOD 1 VOL^CPT MOD 2^CPT MOD 2 VOL^CPT MOD 3^CPT MOD 3 VOL"
- S ECLN=0 F S ECLN=$O(^TMP("ECTMP",$J,ECLN)) Q:ECLN=""!(ECLN["^") D
- .S ECDN="" F S ECDN=$O(^TMP("ECTMP",$J,ECLN,ECDN)) Q:ECDN="" D
- ..S ECUN=0 F S ECUN=$O(^TMP("ECTMP",$J,ECLN,ECDN,ECUN)) Q:ECUN="" D
- ...S ECINZ="^"_$O(^TMP("ECTMP",$J,ECLN,ECDN,ECUN,0))
- ...S ECCN=0 F S ECCN=$O(^TMP("ECTMP",$J,ECINZ,ECCN)) Q:ECCN="" D
- ....S ECPN=0 F S ECPN=$O(^TMP("ECTMP",$J,ECINZ,ECCN,ECPN)) Q:ECPN="" D
- .....S ECPRSN="" F S ECPRSN=$O(^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN)) Q:ECPRSN="" D
- ......S ECPI="",ECCPT=$S($P(ECPN,"~",3)="I":$P(ECPN,"~",2),1:$P($G(^EC(725,$P(ECPN,"~",2),0)),U,5)) I ECCPT'="" S ECPI=$$CPT^ICPTCOD(ECCPT,$P(ECED,".")),ECCPT=$P(ECPI,U,2)
- ......S EC725="" I $P(ECPN,"~",3)="E" S EC725=$G(^EC(725,+$P(ECPN,"~",2),0))
- ......S ECPNAM=$S($P(ECPN,"~",3)="E":$P(EC725,U),$P(ECPN,"~",3)="I":$P(ECPI,U,3),1:"UNKNOWN")
- ......S ECPSY=$P(ECPN,"~",4),ECPSYN="" I ECPSY'="" S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),U,2)
- ......S CNT=CNT+1,^TMP($J,"ECRPT",CNT)=ECLN_U_ECDN_U_ECCN_U_ECUN_U_ECCPT_U_$S($P($G(EC725),U,2)="":ECCPT,1:$P($G(EC725),U,2))_U_ECPNAM_$S(ECPSYN'="":" ["_ECPSYN_"]",1:"")_U_ECPRSN_U_^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN)
- ......D ORDMODS S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_U_MOD1_U_VOL1_U_MOD2_U_VOL2_U_MOD3_U_VOL3
- Q
- ;119, sections added to order CPT modifiers
- ORDMODS ;Find first three mods by volume
- N MOD,ORD,VOL,NUM
- S (MOD1,VOL1,MOD2,VOL2,MOD3,VOL3)="",NUM=0
- S MOD="" F S MOD=$O(^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD)) Q:'+MOD S ORD(-^TMP("ECTMP",$J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD),MOD)=""
- I $D(ORD) S VOL="" F S VOL=$O(ORD(VOL)) Q:VOL=""!(NUM=3) S MOD="" F S MOD=$O(ORD(VOL,MOD)) Q:MOD=""!(NUM=3) S NUM=NUM+1 S @("MOD"_NUM)=$$MODNM(MOD),@("VOL"_NUM)=-VOL
- Q
- ;
- MODNM(IEN) ;Get modifier name
- N MOD,MODI,MODESC
- S MODI=$$MOD^ICPTMOD(IEN,"I",$P(ECED,"."))
- S MOD=$P(MODI,U,2) I MOD="" Q MOD
- S MODESC=$S($P(MODI,U,3)'="":$P(MODI,U,3),1:"Unknown")
- Q MOD_" "_MODESC
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECPROV3 9648 printed Jan 18, 2025@02:59:39 Page 2
- ECPROV3 ;BIR/MAM,JPW - Event Capture Provider Summary (cont'd) ;11/20/12 13:49
- +1 ;;2.0;EVENT CAPTURE;**5,8,18,29,47,56,63,72,95,112,119**;8 May 96;Build 12
- +2 ; This routine is used when printing the report for
- +3 ; all ACCESSIBLE DSS Units
- +4 ;JAM/3/7/03, This routine now combines ECPROV3, ECPROV4 and ECPROV5
- +5 ;
- +6 ;119 Changed all ^TMP($J references to ^TMP("ECTMP",$J so that temporary storage doesn't conflict with exporting data in ^TMP($J
- +7 ;112
- NEW %H
- +8 SET %H=$HOROLOG
- DO YX^%DTC
- SET ECRDT=Y
- +9 ;119 Q
- IF ECL
- Begin DoDot:1
- +10 IF ECPRV=1
- DO UNIT
- QUIT
- +11 IF 'ECPRV
- SET ECC=+$PIECE(^ECD(ECD,0),U,11)
- QUIT
- End DoDot:1
- DO LOC
- if $GET(ECPTYP)="E"
- DO EXPORT
- if $GET(ECPTYP)'="E"
- DO PRINT
- QUIT
- +12 SET ECL=0
- Begin DoDot:1
- +13 FOR I=0:0
- SET ECL=$ORDER(^ECH("ADT",ECL))
- if 'ECL
- QUIT
- Begin DoDot:2
- +14 SET ECLN=$PIECE(^DIC(4,ECL,0),"^")
- IF ECPRV
- DO UNIT
- +15 IF 'ECPRV
- SET ECC=+$PIECE(^ECD(ECD,0),U,11)
- +16 DO LOC
- End DoDot:2
- End DoDot:1
- +17 ;119
- IF $GET(ECPTYP)="E"
- DO EXPORT
- QUIT
- PRINT ;Changes below were made by VMP to correct NOIS ATG-1003-32545
- +1 SET (ECLN,ECPN)=0
- SET ECCN=""
- +2 FOR I=0:0
- SET ECLN=$ORDER(^TMP("ECTMP",$JOB,ECLN))
- if ECLN=""!(ECOUT)!(ECLN["^")
- QUIT
- Begin DoDot:1
- +3 IF 'ECPRV
- DO CATS
- QUIT
- +4 SET ECDN=""
- DO NOUNIT
- FOR I=0:0
- SET ECDN=$ORDER(^TMP("ECTMP",$JOB,ECLN,ECDN))
- if ECDN=""!(ECOUT)
- QUIT
- DO CATS
- End DoDot:1
- +5 KILL ECPNAM
- +6 ;print footer on last page
- DO FOOTER
- +7 QUIT
- CATS ; continue looping
- +1 IF $ORDER(^TMP("ECTMP",$JOB,ECLN,ECDN,""))']""
- DO PAGE
- WRITE !!!,?12,"NO PROCEDURES"
- SET ECPG=1
- QUIT
- +2 DO PAGE
- if ECOUT
- QUIT
- SET ECPG=1
- SET ECUN=0
- FOR I=0:0
- SET ECUN=$ORDER(^TMP("ECTMP",$JOB,ECLN,ECDN,ECUN))
- if ECUN=""!(ECOUT)
- QUIT
- SET ECINZ="^"_$ORDER(^(ECUN,0))
- if $Y+10>IOSL
- DO PAGE
- if ECOUT
- QUIT
- DO PRO
- +3 QUIT
- PRO IF $Y+13>IOSL
- DO PAGE
- IF ECOUT
- QUIT
- +1 WRITE !!,ECUN
- SET ECCN=0
- FOR I=0:0
- SET ECCN=$ORDER(^TMP("ECTMP",$JOB,ECINZ,ECCN))
- if ECCN=""
- DO TOTP
- if ECCN=""!(ECOUT)
- QUIT
- DO MORE
- +2 QUIT
- MORE ;
- +1 ;ALB/ESD - Loop through to get procedure reason and print
- +2 WRITE !,?3,ECCN
- SET ECPN=0
- SET (ECPRSN,ECPI)=""
- +3 FOR
- SET ECPN=$ORDER(^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN))
- if ECPN=""!(ECOUT)
- QUIT
- SET ECUSER=1
- if $Y+10>IOSL
- DO PAGE
- if ECOUT
- QUIT
- KILL ECUSER
- FOR
- SET ECPRSN=$ORDER(^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN))
- if ECPRSN=""!(ECOUT)
- QUIT
- Begin DoDot:1
- +4 SET ECCPT=$SELECT($PIECE(ECPN,"~",3)="I":$PIECE(ECPN,"~",2),1:$PIECE($GET(^EC(725,$PIECE(ECPN,"~",2),0)),"^",5))
- +5 IF ECCPT'=""
- Begin DoDot:2
- +6 ;Changes made by VMP to correct NOIS ATG-1003-32545
- +7 ;use end date/date range to get CPT description; CTD project.
- +8 SET ECPI=$$CPT^ICPTCOD(ECCPT,$PIECE(ECED,"."))
- SET ECCPT=$PIECE(ECPI,"^",2)
- End DoDot:2
- +9 SET EC725=""
- IF $PIECE(ECPN,"~",3)="E"
- SET EC725=$GET(^EC(725,+$PIECE(ECPN,"~",2),0))
- +10 ;112
- SET ECPNAM=$SELECT($PIECE(ECPN,"~",3)="E":$PIECE(EC725,"^"),$PIECE(ECPN,"~",3)="I":$PIECE(ECPI,"^",3),1:"UNKNOWN")
- +11 SET ECPSY=$PIECE(ECPN,"~",4)
- SET ECPSYN=""
- +12 IF ECPSY'=""
- SET ECPSYN=$PIECE($GET(^ECJ(ECPSY,"PRO")),"^",2)
- +13 ;112
- WRITE !,?6,$JUSTIFY(ECCPT_" ",6),$JUSTIFY($SELECT($PIECE($GET(EC725),"^",2)="":ECCPT_" ",1:$PIECE($GET(EC725),"^",2)_" "),6),?18,$EXTRACT(ECPNAM,1,40)
- +14 if ECPSYN'=""
- WRITE " [",$EXTRACT(ECPSYN,1,25),"]"
- +15 if $DATA(ECRY)
- WRITE ?70,ECPRSN
- +16 WRITE ?105,$JUSTIFY(^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN),6)
- +17 ;print CPT procedure modifiers
- +18 SET IEN=""
- +19 FOR
- SET IEN=$ORDER(^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN,"MOD",IEN))
- if IEN=""
- QUIT
- Begin DoDot:2
- +20 ;used end date to get description,CTD project
- +21 SET MODI=$$MOD^ICPTMOD(IEN,"I",$PIECE(ECED,"."))
- +22 SET MOD=$PIECE(MODI,"^",2)
- IF MOD=""
- KILL MODI
- QUIT
- +23 SET MODESC=$PIECE(MODI,"^",3)
- IF MODESC=""
- SET MODESC="UNKNOWN"
- +24 SET MODAMT=^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN,"MOD",IEN)
- +25 WRITE !?10,"- ",MOD," ",MODESC," (",MODAMT,")"
- +26 IF ($Y+6)>IOSL
- DO PAGE
- End DoDot:2
- IF ECOUT
- QUIT
- +27 KILL MODESC,MOD,IEN,MODAMT,MODI,EC725
- End DoDot:1
- +28 QUIT
- LOC SET (ECDFN,ECOUT,^TMP("ECTMP",$JOB,ECLN))=0
- +1 FOR I=0:0
- SET ECDFN=$ORDER(^ECH("ADT",ECL,ECDFN))
- if 'ECDFN
- QUIT
- Begin DoDot:1
- +2 IF ECPRV
- DO GECD
- QUIT
- +3 DO GMM
- End DoDot:1
- +4 QUIT
- GECD SET ECD=0
- FOR I=0:0
- SET ECD=$ORDER(^ECH("ADT",ECL,ECDFN,ECD))
- if 'ECD
- QUIT
- DO GMM
- +1 QUIT
- GMM SET MM=ECSD
- FOR I=0:0
- SET MM=$ORDER(^ECH("ADT",ECL,ECDFN,ECD,MM))
- if 'MM!(MM>ECED)
- QUIT
- DO LOC1
- +1 QUIT
- LOC1 SET ECFN=0
- FOR I=0:0
- SET ECFN=$ORDER(^ECH("ADT",ECL,ECDFN,ECD,MM,ECFN))
- if 'ECFN
- QUIT
- DO UTL
- +1 QUIT
- UTL ; set ^TMP("ECTMP",$J
- +1 if '$DATA(^ECH(+ECFN,0))!(+$GET(ECD)'=$PIECE($GET(^ECH(+ECFN,0)),"^",7))
- QUIT
- +2 SET ECEC=^ECH(+ECFN,0)
- SET ECV=+$PIECE(ECEC,"^",10)
- SET ECC=+$PIECE(ECEC,"^",8)
- +3 ;S ECP=$P(ECEC,"^",9),ECU=+$P(ECEC,"^",11)
- +4 SET ECP=$PIECE(ECEC,"^",9)
- SET ECU=$$GETPPRV^ECPRVMUT(ECFN,.ECUN)
- SET ECUN=$SELECT(ECU:"UNKNOWN",1:$PIECE(ECUN,"^",2))
- +5 SET ECCN=$SELECT($PIECE($GET(^EC(726,ECC,0)),"^")]"":$PIECE(^(0),"^"),1:"None")
- +6 if ECP']""
- QUIT
- +7 SET ECD=+$PIECE(ECEC,"^",7)
- +8 IF ECPRV=1
- if '$DATA(ECDU(ECD))
- QUIT
- SET ECDN=ECDU(ECD)
- +9 IF ECPRV=2
- SET ECDN=$SELECT($PIECE($GET(^ECD(ECD,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +10 ;S ECUN=$S($P($G(^VA(200,ECU,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- +11 SET ECPSY=+$ORDER(^ECJ("AP",ECL,ECD,ECC,ECP,""))
- SET ECPN=""
- +12 SET ECFILE=$PIECE(ECP,";",2)
- SET ECFILE=$SELECT($EXTRACT(ECFILE)="I":81,$EXTRACT(ECFILE)="E":725,1:"UNKNOWN")
- +13 IF ECFILE=81
- SET ECPN=$PIECE($$CPT^ICPTCOD(+ECP,$PIECE(ECED,".")),"^",3)
- +14 IF ECFILE=725
- SET ECPN=$PIECE($GET(^EC(725,+ECP,0)),"^")
- +15 IF ECFILE="UNKNOWN"!(ECPN="")
- SET ECPN="UNKNOWN"
- +16 ;Changes made by VMP to correct NOIS SDC-1003-60397
- +17 SET ECPN=$EXTRACT(ECPN,1,5)_"~"_$PIECE(ECP,";")_"~"_$EXTRACT($PIECE(ECP,";",2))_"~"_ECPSY
- +18 ;Get Procedure CPT modifiers
- +19 SET ECMODF=0
- KILL ECMOD
- +20 IF $ORDER(^ECH(+ECFN,"MOD",0))'=""
- SET ECMODF=$$MOD^ECUTL(+ECFN,"I",.ECMOD)
- +21 ;
- +22 ;ALB/ESD - Get procedure reason from EC Patient file (#721) record
- +23 NEW ECLNK
- +24 SET ECPRSN=""
- +25 SET ECLNK=+$PIECE(ECEC,"^",23)
- +26 IF +ECLNK>0
- Begin DoDot:1
- +27 SET ECPRSN=$PIECE($GET(^ECL(ECLNK,0)),"^",1)
- +28 if +ECPRSN'>0
- SET ECPRSN="REASON NOT DEFINED"
- +29 if +ECPRSN>0
- SET ECPRSN=$PIECE(^ECR(ECPRSN,0),"^",1)
- End DoDot:1
- +30 if +ECLNK'>0
- SET ECPRSN="REASON NOT DEFINED"
- +31 ;group proc reason-not print
- IF '$DATA(ECRY)
- SET ECPRSN="REASON NOT DEFINED"
- +32 IF '$DATA(^TMP("ECTMP",$JOB,ECLN,ECDN,ECUN))
- SET ECINC=ECINC+1
- SET ECINZ="^"_ECINC
- SET ^(ECUN)=0
- SET ^(ECUN,ECINC)=0
- +33 SET ECINZ="^"_$ORDER(^TMP("ECTMP",$JOB,ECLN,ECDN,ECUN,0))
- +34 IF '$DATA(^TMP("ECTMP",$JOB,ECINZ,ECCN))
- SET ^TMP("ECTMP",$JOB,ECINZ,ECCN)=0
- +35 ;
- +36 ;ALB/ESD - Add procedure reason to ^TMP array
- +37 IF '$DATA(^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN))
- SET ^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN)=0
- +38 SET ^TMP("ECTMP",$JOB,ECLN)=^TMP("ECTMP",$JOB,ECLN)+ECV
- +39 SET ^TMP("ECTMP",$JOB,ECLN,ECDN,ECUN)=^TMP("ECTMP",$JOB,ECLN,ECDN,ECUN)+ECV
- +40 SET ^TMP("ECTMP",$JOB,ECINZ,ECCN)=^TMP("ECTMP",$JOB,ECINZ,ECCN)+ECV
- +41 ;
- +42 ;ALB/ESD - Add procedure reason to ^TMP array
- +43 SET ^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN)=^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN)+ECV
- +44 ;ALB/JAM - Add Procedure CPT modifier to ^TMP array
- +45 SET MOD=""
- FOR
- SET MOD=$ORDER(ECMOD(MOD))
- if MOD=""
- QUIT
- Begin DoDot:1
- +46 SET ^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD)=$GET(^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD))+ECV
- End DoDot:1
- +47 QUIT
- PAGE ; end of page
- +1 if $DATA(ECPG)
- DO FOOTER
- +2 IF $DATA(ECPG)
- IF $EXTRACT(IOST,1,2)="C-"
- WRITE !!,"Press <RET> to continue, or ^ to quit "
- READ X:DTIME
- IF '$TEST!(X="^")
- SET ECOUT=1
- QUIT
- HDR ; print heading
- +1 if $Y
- WRITE @IOF
- WRITE !!,?49,"EVENT CAPTURE PROVIDER SUMMARY",!,?49,"FROM "_$PIECE(ECDATE,"^")_" TO "_$PIECE(ECDATE,"^",2),!,?49,"Run Date : ",ECRDT
- +2 ;112
- WRITE !!?3,"Category",?105,"Procedure/Reason",!,?6,"CPT",?12,"Proc",?18,"Procedure Name"
- +3 ;112
- if $DATA(ECRY)
- WRITE ?70,"Procedure Reason #1"
- +4 ;112
- WRITE ?105,"Volume*",!,?6,"Code",?12,"Code",!,?10,"CPT Modifier (volume)",!
- +5 FOR LINE=1:1:132
- WRITE "-"
- +6 WRITE !!,"Location: "_ECLN,!
- if ECDN]""
- WRITE "DSS Unit: "_ECDN
- +7 IF ECPRV
- IF $DATA(ECUSER)
- WRITE !!,ECUN,!,ECCN
- +8 QUIT
- +1 WRITE !!?4,"*Volume totals may represent days, minutes, numbers of procedures and/or a combination of these."
- +2 ;112
- IF $GET(ECRY)'=""
- WRITE !?4,"Procedure/Reason Volume = count of unique combinations of procedure code and procedure reason"
- +3 QUIT
- +4 ;
- TOTP if ECOUT
- QUIT
- WRITE !,?105,"------",!,"Total Procedures for "_ECUN,?105,$JUSTIFY(^TMP("ECTMP",$JOB,ECLN,ECDN,ECUN),6)
- +1 QUIT
- UNIT ; set units
- +1 SET CNT=0
- FOR I=0:0
- SET CNT=$ORDER(UNIT(CNT))
- if 'CNT
- QUIT
- SET ECDU(+UNIT(CNT))=$PIECE(UNIT(CNT),"^",2)
- +2 QUIT
- +3 ;
- NOUNIT ;Nothing there
- +1 IF $ORDER(^TMP("ECTMP",$JOB,ECLN,ECDN))']""
- DO PAGE
- WRITE !!!,?12,"NO PROCEDURES",!
- SET ECPG=1
- +2 QUIT
- +3 ;
- EXPORT ;119 Entire section added in patch 119 for exporting data to excel
- +1 NEW CNT,ECLN,ECPN,ECCN,I,ECDN,ECINZ,ECUN,ECPRSN,ECPI,ECCPT,EC725,ECPNAM,ECPSY,ECPSYN,MOD1,VOL1,MOD2,VOL2,MOD3,VOL3
- +2 SET CNT=1
- SET ^TMP($JOB,"ECRPT",CNT)="LOCATION^DSS UNIT^CATEGORY^PROVIDER^CPT CODE^PROCEDURE CODE^PROCEDURE NAME^PROCEDURE REASON#1^PROCEDURE/REASON VOLUME^CPT MOD 1^CPT MOD 1 VOL^CPT MOD 2^CPT MOD 2 VOL^CPT MOD 3^CPT MOD 3 VOL"
- +3 SET ECLN=0
- FOR
- SET ECLN=$ORDER(^TMP("ECTMP",$JOB,ECLN))
- if ECLN=""!(ECLN["^")
- QUIT
- Begin DoDot:1
- +4 SET ECDN=""
- FOR
- SET ECDN=$ORDER(^TMP("ECTMP",$JOB,ECLN,ECDN))
- if ECDN=""
- QUIT
- Begin DoDot:2
- +5 SET ECUN=0
- FOR
- SET ECUN=$ORDER(^TMP("ECTMP",$JOB,ECLN,ECDN,ECUN))
- if ECUN=""
- QUIT
- Begin DoDot:3
- +6 SET ECINZ="^"_$ORDER(^TMP("ECTMP",$JOB,ECLN,ECDN,ECUN,0))
- +7 SET ECCN=0
- FOR
- SET ECCN=$ORDER(^TMP("ECTMP",$JOB,ECINZ,ECCN))
- if ECCN=""
- QUIT
- Begin DoDot:4
- +8 SET ECPN=0
- FOR
- SET ECPN=$ORDER(^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN))
- if ECPN=""
- QUIT
- Begin DoDot:5
- +9 SET ECPRSN=""
- FOR
- SET ECPRSN=$ORDER(^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN))
- if ECPRSN=""
- QUIT
- Begin DoDot:6
- +10 SET ECPI=""
- SET ECCPT=$SELECT($PIECE(ECPN,"~",3)="I":$PIECE(ECPN,"~",2),1:$PIECE($GET(^EC(725,$PIECE(ECPN,"~",2),0)),U,5))
- IF ECCPT'=""
- SET ECPI=$$CPT^ICPTCOD(ECCPT,$PIECE(ECED,"."))
- SET ECCPT=$PIECE(ECPI,U,2)
- +11 SET EC725=""
- IF $PIECE(ECPN,"~",3)="E"
- SET EC725=$GET(^EC(725,+$PIECE(ECPN,"~",2),0))
- +12 SET ECPNAM=$SELECT($PIECE(ECPN,"~",3)="E":$PIECE(EC725,U),$PIECE(ECPN,"~",3)="I":$PIECE(ECPI,U,3),1:"UNKNOWN")
- +13 SET ECPSY=$PIECE(ECPN,"~",4)
- SET ECPSYN=""
- IF ECPSY'=""
- SET ECPSYN=$PIECE($GET(^ECJ(ECPSY,"PRO")),U,2)
- +14 SET CNT=CNT+1
- SET ^TMP($JOB,"ECRPT",CNT)=ECLN_U_ECDN_U_ECCN_U_ECUN_U_ECCPT_U_$SELECT($PIECE($GET(EC725),U,2)="":ECCPT,1:$PIECE($GET(EC725),U,2))_U_ECPNAM_$SELECT(ECPSYN'="":" ["_ECPSYN_"]",1:"")_U_ECPRSN_U_^TMP
- ("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN)
- +15 DO ORDMODS
- SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_U_MOD1_U_VOL1_U_MOD2_U_VOL2_U_MOD3_U_VOL3
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 QUIT
- +17 ;119, sections added to order CPT modifiers
- ORDMODS ;Find first three mods by volume
- +1 NEW MOD,ORD,VOL,NUM
- +2 SET (MOD1,VOL1,MOD2,VOL2,MOD3,VOL3)=""
- SET NUM=0
- +3 SET MOD=""
- FOR
- SET MOD=$ORDER(^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD))
- if '+MOD
- QUIT
- SET ORD(-^TMP("ECTMP",$JOB,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD),MOD)=""
- +4 IF $DATA(ORD)
- SET VOL=""
- FOR
- SET VOL=$ORDER(ORD(VOL))
- if VOL=""!(NUM=3)
- QUIT
- SET MOD=""
- FOR
- SET MOD=$ORDER(ORD(VOL,MOD))
- if MOD=""!(NUM=3)
- QUIT
- SET NUM=NUM+1
- SET @("MOD"_NUM)=$$MODNM(MOD)
- SET @("VOL"_NUM)=-VOL
- +5 QUIT
- +6 ;
- MODNM(IEN) ;Get modifier name
- +1 NEW MOD,MODI,MODESC
- +2 SET MODI=$$MOD^ICPTMOD(IEN,"I",$PIECE(ECED,"."))
- +3 SET MOD=$PIECE(MODI,U,2)
- IF MOD=""
- QUIT MOD
- +4 SET MODESC=$SELECT($PIECE(MODI,U,3)'="":$PIECE(MODI,U,3),1:"Unknown")
- +5 QUIT MOD_" "_MODESC