Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXRACPT

ECXRACPT.m

Go to the documentation of this file.
  1. ECXRACPT ;ALB/DAN - Radiology extract invalid CPT report ;7/25/18 14:29
  1. ;;3.0;DSS EXTRACTS;**170**;Dec 22, 1997;Build 12
  1. EN ;entry point from menu option
  1. N ECXPORT,CNT,ECXHEAD,ECXERR,ECXARRAY,ECXAUD,ECXDIV,ECXALL,ECXDESC,ECXPGM,ECXSAVE,D0
  1. W @IOF,!!,"Radiology (RAD) Extract CPT Code Audit",!!
  1. ;ecxaud=1 stops user from being able to select a date range
  1. S ECXHEAD="RAD",ECXAUD=1
  1. ;select extract
  1. D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
  1. I ECXERR D AUDIT^ECXKILL Q
  1. ;select all radiology sites/divisions
  1. S ECXALL=1 D RAD^ECXDVSN2(.ECXDIV,ECXALL,.ECXERR)
  1. I ECXERR D AUDIT^ECXKILL Q
  1. S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q
  1. .K ^TMP($J,"ECXPORT")
  1. .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^DIVISION/SITE^IMAGING TYPE (FEEDER LOCATION)^PROCEDURE DATE^FEEDER KEY^PROCEDURE^PATIENT DFN",CNT=1
  1. .D PROCESS
  1. .D EXPDISP^ECXUTL1
  1. .D AUDIT^ECXKILL
  1. W !!
  1. S ECXPGM="PROCESS^ECXRACPT",ECXDESC="Radiology Extract Invalid CPT Report"
  1. S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")=""
  1. W !
  1. D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
  1. I ECXSAVE("POP")=1 D Q
  1. .W !!,?5,"Try again later... exiting.",!
  1. .D AUDIT^ECXKILL
  1. I ECXSAVE("ZTSK")=0 D
  1. .K ECXSAVE,ECXPGM,ECXDESC
  1. .D PROCESS
  1. I IO'=IO(0) D ^%ZISC
  1. D HOME^%ZIS
  1. D AUDIT^ECXKILL
  1. Q
  1. ;
  1. PROCESS ;queued entry
  1. N J,X,Y,PG,DIV,EC,ECFK,ECFL,QFLG,TYPE,TYPENMN,DIQ,DR,DA,DIR,DIRUT,DTOUT,DUOUT,CPT,DAY,%DT,ECXRUN,ECX,DIC,ECXEXT,ECXDEF,DATA,SEQ,ECXP
  1. K ^TMP($J,"ECXCPT")
  1. S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
  1. S (QFLG,PG)=0
  1. ;get run date in external format
  1. S ECXRUN=$$FMTE^XLFDT($E($$NOW^XLFDT,1,12))
  1. ;setup array of imaging types
  1. S TYPE=0 F S TYPE=$O(^RA(79.2,TYPE)) Q:+TYPE<1 D
  1. .K ECX S DIC="^RA(79.2,",DR=".01;3",DIQ="ECX",DIQ(0)="I",DA=TYPE D EN^DIQ1
  1. .S TYPE(TYPE)=ECX(79.2,TYPE,.01,"I")_U_ECX(79.2,TYPE,3,"I")
  1. ;process the extract records
  1. S J="" F S J=$O(^ECX(727.814,"AC",ECXEXT,J)) Q:'J I $D(^ECX(727.814,J,0)) S EC=^(0),DIV=$P(EC,U,4),ECFL=DIV_"-"_$P(EC,U,21) D
  1. .S ECFK=$P(EC,U,10),ECXP=$P(EC,U,11)
  1. .S CPT=$E(ECFK,1,5) ;Get just CPT code from the CPT Code and modifier info in ECFK
  1. .S DAY=$$ECXDATEX^ECXUTL($P(EC,U,9)) ;Convert DSS to readable date
  1. .S X=DAY,%DT="X" D ^%DT S DAY=Y ;Convert readable date to FM date
  1. .I $$STATCHK^ICPTAPIU(CPT,DAY) Q ;If CPT code was valid on this date, skip it
  1. .S ^TMP($J,"ECXCPT",DIV,ECFL,J)=DAY_U_ECXP_U_$$GET1^DIQ(71,$P(EC,U,11),.01)_U_$P(EC,U,5)
  1. .Q
  1. ;
  1. ;Print/export report
  1. U IO
  1. I '$G(ECXPORT) I '$D(^TMP($J,"ECXCPT")) S DIV=0 D HEADER W !,"No data found." Q
  1. S DIV="" F S DIV=$O(^TMP($J,"ECXCPT",DIV)) Q:DIV=""!(QFLG) D
  1. .D:'$G(ECXPORT) HEADER
  1. .S ECFL="" F S ECFL=$O(^TMP($J,"ECXCPT",DIV,ECFL)) Q:ECFL=""!(QFLG) S TYPE=+$P(ECFL,"-",2) D
  1. ..S TYPENMN=$E($P($G(TYPE(TYPE)),U),1,18)
  1. ..S SEQ="" F S SEQ=$O(^TMP($J,"ECXCPT",DIV,ECFL,SEQ)) Q:SEQ=""!(QFLG) D
  1. ...I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG
  1. ...S DATA=^TMP($J,"ECXCPT",DIV,ECFL,SEQ)
  1. ...I $G(ECXPORT) D Q
  1. ....S ^TMP($J,"ECXPORT",CNT)=ECXEXT_U_$P($G(ECXDIV(DIV)),U,2)_"("_$P($G(ECXDIV(DIV)),U)_")"_U_TYPENMN_" ("_ECFL_")"
  1. ....S ^TMP($J,"ECXPORT",CNT)=^TMP($J,"ECXPORT",CNT)_U_$TR($$FMTE^XLFDT($P(DATA,U),"2F")," ",0)_U_$P(DATA,U,2)_U_$P(DATA,U,3)_U_$P(DATA,U,4),CNT=CNT+1 Q
  1. ...W TYPENMN," (",ECFL,")"
  1. ...W !,?3,$P(DATA,U,2),?11,$E($P(DATA,U,3),1,45),?58,$TR($$FMTE^XLFDT($P(DATA,U),"2F")," ",0),?69,$P(DATA,U,4),!
  1. ...Q
  1. ..Q
  1. .Q
  1. Q
  1. ;
  1. N JJ,SS,LN
  1. S $P(LN,"-",80)="-"
  1. I $E(IOST)="C" D
  1. .S SS=22-$Y F JJ=1:1:SS W !
  1. .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
  1. Q:QFLG
  1. W:$Y!($E(IOST)="C") @IOF S PG=PG+1
  1. W !,"Radiology (RAD) Extract CPT Code Audit"
  1. W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT")
  1. W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
  1. W !,"Report Run Date/Time: "_ECXRUN
  1. I $D(ECXDIV(DIV)) W !,"Division/Site: "_$P(ECXDIV(DIV),U,2)_" ("_DIV_")",?68,"Page: "_PG
  1. I '$D(ECXDIV(DIV)) W !,"Division/Site: "_"Unknown",?68,"Page: "_PG
  1. W !!,"Imaging Type (Feeder Location)",?58,"Procedure"
  1. W !?3,"FdrKey",?11,"Procedure",?58,"Date",?69,"DFN"
  1. W !,LN,!
  1. Q