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

ECXAECQ.m

Go to the documentation of this file. 
  1. ECXAECQ ;ALB/JAP - ECQ Extract Audit Report ;3/3/14  14:51
  1.  ;;3.0;DSS EXTRACTS;**8,33,35,43,44,123,149**;Dec 22, 1997;Build 27
  1.  ;
  1. EN ;entry point for ECQ extract audit report
  1.  N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXQV,ECXPOS,ECXYR,ECXMTH,ECXPFLG,ECXOPT,QFLG,Q2FLG,ECXPORT,RCNT,ECCL ;149
  1.  S (ECXERR,QFLG)=0
  1.  ;ecxaud=0 for 'extract' audit
  1.  S ECXHEAD="ECQ",ECXAUD=0
  1.  W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
  1.  ;select extract
  1.  D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
  1.  Q:ECXERR
  1.  ;determine if version 3 and using EC National Procedure Codes for current fiscal year
  1.  D FILE^DID(509850.6,,"VERSION","ARR","ERR")
  1.  S ECXQV=$G(ARR("VERSION"))
  1.  S ECXPOS=29
  1.  I +ECXQV=3 D 
  1.  .S ECXYR=$E($P(ECXARRAY("START"),",",2),4,5)
  1.  .S ECXMTH=$E(ECXARRAY("START"),1,3)
  1.  .I (ECXMTH="OCT")!(ECXMTH="NOV")!(ECXMTH="DEC") S ECXYR=ECXYR+1
  1.  .S ECDA=0 F  S ECDA=$O(^ACK(509850.8,ECDA)) Q:'ECDA!QFLG  S ECDIV=0 F  S ECDIV=$O(^ACK(509850.8,ECDA,2,ECDIV)) Q:'ECDIV!QFLG  D
  1.  ..S ECCL=0 F  S ECCL=$O(^ACK(509850.8,ECDA,2,ECDIV,2,"B",ECXYR,ECCL)) Q:'ECCL!QFLG  D
  1.  ...S ECXPFLG=$P($G(^ACK(509850.8,ECDA,2,ECDIV,2,ECCL,0)),U,2)
  1.  ...I ECXPFLG D  S QFLG=1
  1.  ....W !!,"Your site has division(s) which are using EC National Procedure Codes for the",!,"fiscal year covering the time period of this extract."
  1.  ....W !!,"You have the option to display either EC National Procedure Codes or CPT Codes",!,"for these division(s)."
  1.  ....F  D  Q:Q2FLG
  1.  .....S Q2FLG=1
  1.  .....S DIR(0)="S^1:EC National Procedure Codes;2:CPT Codes",DIR("A")="Selection",DIR("B")=1 D ^DIR K DIR S ECXOPT=Y
  1.  .....I X["^" W !!,"This is a required response" S Q2FLG=0
  1.  ....I ECXOPT=1 S ECXPOS=12
  1.  ;currently, quasar does not accommodate multi-divisional sites
  1.  S ECXALL=0
  1.  D ECQ^ECXDVSN1(.ECXDIV,ECXALL,.ECXERR)
  1.  I ECXERR=1 D  Q
  1.  .W !!,?5,"Try again later... exiting.",!
  1.  .D AUDIT^ECXKILL
  1.  ;determine output device and queue if requested
  1.  S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1  I $G(ECXPORT) D  Q  ;149 Section added
  1.  .K ^TMP($J,"ECXPORT")
  1.  .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^QUASAR SITE^DIVISION^DSS UNIT^PROCEDURE^PROCEDURE DESCRIPTION^VOLUME",RCNT=1
  1.  .D PROCESS
  1.  .D EXPDISP^ECXUTL1
  1.  .D AUDIT^ECXKILL
  1.  W !
  1.  S ECXPGM="PROCESS^ECXAECQ",ECXDESC="ECQ Extract Audit Report"
  1.  S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="",ECXSAVE("ECXPOS")=""
  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^ECXAECQ
  1.  I IO'=IO(0) D ^%ZISC
  1.  D HOME^%ZIS
  1.  D AUDIT^ECXKILL
  1.  Q
  1.  ;
  1. PROCESS ;process data in file #727.825
  1.  N X,Y,W,ADIV,DATA,DATE,DIV,DIVACK,IEN,LOC,ECNIEN,ECXLINK
  1.  N UNIT,UNITN,VOL,PROC,PROCN,SDIV,QQFLG,CNT
  1.  K ^TMP($J,"ECXAUD"),^TMP($J,"ECXPROC")
  1.  S (CNT,QQFLG)=0,ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
  1.  S X=ECXARRAY("START") D ^%DT S ECXSTART=Y,X=ECXARRAY("END")
  1.  D ^%DT S ECXEND=Y
  1.  ;get run date in external format
  1.  D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
  1.  ;get the dss unit links for this division/site
  1.  S DIV=0
  1.  F  S DIV=$O(ECXDIV(DIV)) Q:DIV=""  D
  1.  .S DIVACK=$P(ECXDIV(DIV),U,1),ECXLINK(DIV)=^ACK(509850.8,DIVACK,"DSS")
  1.  ;get extract records in date range
  1.  S IEN=""
  1.  F  S IEN=$O(^ECX(727.825,"AC",ECXEXT,IEN)) Q:IEN=""  D  Q:QQFLG
  1.  .S DATA=^ECX(727.825,IEN,0),DIV=$P(DATA,U,4),DATE=$P(DATA,U,9)
  1.  .S ADIV=$P(^ECX(727.825,IEN,1),U,11) S:ADIV="" ADIV="UNK"
  1.  .I +ADIV S X=^DG(40.8,ADIV,0),ADIV=$P(X,U)_" ("_$P(X,U,2)_")"
  1.  .;convert free text date to fm internal format date
  1.  .S $E(DATE,1,2)=$E(DATE,1,2)-17
  1.  .Q:$L(DATE)<7  Q:(DATE<ECXSTART)  Q:(DATE>ECXEND)
  1.  .;if location is among those selected, then tally event capture data
  1.  .I $D(ECXDIV(DIV)) D  Q:QQFLG
  1.  ..;any quasar site that doesn't have links to dss is identified by "xx"
  1.  ..S UNIT=$P(DATA,U,10)
  1.  ..S LOC=$S(UNIT=$P(ECXLINK(DIV),U,1):"A",UNIT=$P(ECXLINK(DIV),U,2):"S",1:"XX")
  1.  ..;any invalid cpt code is identified as "xxxxx"
  1.  ..S PROC=$E($P(DATA,U,ECXPOS),1,5),VOL=$P(DATA,U,13),PROCN=""
  1.  ..I ECXPOS=12 D
  1.  ...S ECNIEN=0,ECNIEN=$O(^EC(725,"D",PROC,ECNIEN)) Q:'ECNIEN
  1.  ...S PROCN=$P($G(^EC(725,+ECNIEN,0)),U)
  1.  ..I PROCN="" D
  1.  ...S ECNIEN=0,ECNIEN=$$CODEN^ICPTCOD(PROC) I +ECNIEN>0 S PROCN=$P($$CPT^ICPTCOD(PROC,DATE),U,3)
  1.  ..S PROC="A"_PROC S:VOL="" VOL=1
  1.  ..S:PROCN="" PROCN="Unknown"
  1.  ..I '$D(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)) S ^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)=0_U_PROCN
  1.  ..S $P(^(PROC),U,1)=$P(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC),U,1)+VOL,CNT=CNT+1
  1.  ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ
  1.  ;print the report
  1.  D PRINT
  1.  I $G(ECXPORT) Q  ;149 Stop processing if exporting
  1.  D AUDIT^ECXKILL
  1.  Q
  1.  ;
  1. PRINT ;print quasar data by site and dss unit order
  1.  N JJ,SS,LN,P,LOC,UNITN,PG,QFLG,GTOT,STOT,TOT,PROC,PROCN
  1.  N DIR,DIRUT,DIV,DIVNM,DTOUT,DUOUT
  1.  U IO
  1.  I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
  1.  S (QFLG,PG)=0,$P(LN,"-",80)="",DIV=""
  1.  F  S DIV=$O(ECXDIV(DIV)) Q:DIV=""  D  Q:QFLG
  1.  .S DIVNM=$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"
  1.  .I '$G(ECXPORT) D HEADER Q:QFLG  ;149
  1.  .S GTOT=0,STOT("A")=0,STOT("S")=0,STOT("XX")=0
  1.  .I '$D(^TMP($J,"ECXAUD",DIV)) D  Q
  1.  ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_"^"_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_"^No data available for this QUASAR site" Q  ;149
  1.  ..W !!,?5,"No data available for this QUASAR site.",!!
  1.  .I $D(^TMP($J,"ECXAUD",DIV)) S ADIV="" D
  1.  ..F  S ADIV=$O(^TMP($J,"ECXAUD",DIV,ADIV)) Q:ADIV=""  S LOC="" D  Q:QFLG
  1.  ...F  S LOC=$O(^TMP($J,"ECXAUD",DIV,ADIV,LOC)) Q:LOC=""  D  Q:QFLG
  1.  ....;write the unit name
  1.  ....S UNITN=$S(LOC="A":"Audiology",LOC="S":"Speech Pathology",1:"Unknown"),PROC=""
  1.  ....I '$G(ECXPORT) D:($Y+2>IOSL) HEADER Q:QFLG  W !,"Division: ("_ADIV_")",!?20,UNITN ;149
  1.  ....F  S PROC=$O(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)) Q:PROC=""  D  Q:QFLG
  1.  .....S TOT=+^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC),PROCN=$P(^(PROC),U,2),P=$E(PROC,2,99)
  1.  .....S SDIV(ADIV,LOC)=$G(SDIV(ADIV,LOC))+TOT
  1.  .....S STOT(LOC)=STOT(LOC)+TOT,GTOT=GTOT+TOT
  1.  .....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_ADIV_U_UNITN_U_P_U_PROCN_U_TOT,RCNT=RCNT+1 Q  ;149
  1.  .....D:($Y+3>IOSL) HEADER Q:QFLG  W !,?25,P,?35,$E(PROCN,1,30),?68,$$RJ^XLFSTR(TOT,5," ")
  1.  ....;write the unit subtotal
  1.  ....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^^^Volume for "_UNITN_"^^"_+$G(SDIV(ADIV,LOC)),RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q  ;149
  1.  ....D:($Y+4>IOSL) HEADER Q:QFLG
  1.  ....W !,?25,$E(LN,1,54)
  1.  ....W !,"Volume for "_UNITN_":",?68,$$RJ^XLFSTR(+$G(SDIV(ADIV,LOC)),5," "),!!
  1.  .;write the division grandtotal
  1.  .I $G(ECXPORT) D  Q  ;149 section added
  1.  ..S ^TMP($J,"ECXPORT",RCNT)="^^^^Total Volume for Audiology^^"_STOT("A"),RCNT=RCNT+1
  1.  ..S ^TMP($J,"ECXPORT",RCNT)="^^^^Total Volume for Speech Pathology^^"_STOT("S"),RCNT=RCNT+1
  1.  ..S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^^^Grand Total for Site "_DIVNM_"^^"_GTOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1
  1.  .D:($Y+5>IOSL) HEADER Q:QFLG
  1.  .W !!,"Total Volume for Audiology:",?68,$$RJ^XLFSTR(STOT("A"),5," ")
  1.  .W !,"Total Volume for Speech Pathology:",?68,$$RJ^XLFSTR(STOT("S"),5," ")
  1.  .W !!,"Grand Total for Site "_DIVNM_":",?68,$$RJ^XLFSTR(GTOT,5," ")
  1.  ;print the audit descriptive narrative
  1.  I $G(ECXPORT) Q  ;149
  1.  I $E(IOST)'="C" D
  1.  .W @IOF S PG=PG+1
  1.  .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
  1.  .W !,"DSS Extract Log #:       "_ECXEXT
  1.  .W !,"Date Range of Audit:     "_ECXARRAY("START")_" to "_ECXARRAY("END")
  1.  .W !,"Report Run Date/Time:    "_ECXRUN,?68,"Page: ",PG
  1.  .W !!,LN,!!
  1.  .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ
  1.  I ($E(IOST)="C"),('QFLG) D
  1.  .S SS=22-$Y F JJ=1:1:SS W !
  1.  .S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
  1.  Q
  1.  ;
  1.  N JJ,SS
  1.  I ($E(IOST)="C"),('QFLG) 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 !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
  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.  W !,"QUASAR Site:          "_$P(ECXDIV(DIV),U,2)_"("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG ;149 Added space to line up data with other headers
  1.  W !!,"DSS Unit",?25,"Procedure",?68,"Volume"
  1.  W !,LN
  1.  Q