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

ECXSARAD.m

Go to the documentation of this file.
  1. ECXSARAD ;BIR/DMA-SAS Report from Radiology Extract; 25 Apr 95 / 11:03 AM ;4/25/14 12:47
  1. ;;3.0;DSS EXTRACTS;**8,149**;Dec 22, 1997;Build 27
  1. EN ;entry point from menu option
  1. N ECXPORT,CNT ;149
  1. W @IOF,!!,"Radiology Extract SAS Report",!!
  1. ;ecxaud=1 for 'sas' audit
  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 ;149 Section added
  1. .K ^TMP($J,"ECXPORT")
  1. .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^DIVISION/SITE^FEEDER LOCATION^FEEDER KEY^QUANTITY",CNT=1
  1. .D PROCESS
  1. .D EXPDISP^ECXUTL1
  1. .D AUDIT^ECXKILL
  1. W !!
  1. S ECXPGM="PROCESS^ECXSARAD",ECXDESC="Radiology Extract SAS 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.",! ;149 Fixed spelling of "again"
  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,K,X,Y,JJ,SS,LN,PG,DIV,EC,ECFK,ECFL,QFLG,TOT,TYPE,TYPENM,DIQ,DR,DA,DIR,DIRUT,DTOUT,DUOUT
  1. K ^TMP($J,"ECXAUD")
  1. S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
  1. S (QFLG,PG)=0,$P(LN,"-",80)=""
  1. ;get run date in external format
  1. D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
  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) I ECFK="" S ECFK=$P(EC,U,11)
  1. .I $P(EC,U,10)="",$P(EC,U,11)=468 S ECFK=777777
  1. .S MODS=";"_$P(EC,U,17)_";"
  1. .S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+1
  1. .I MODS[";1;" S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+1
  1. .I MODS[";2;" S ^(888888)=$G(^TMP($J,"ECXAUD",DIV,ECFL,888888))+1
  1. .I MODS[";3;" S ^(999999)=$G(^TMP($J,"ECXAUD",DIV,ECFL,999999))+1
  1. ;print the report
  1. U IO
  1. S DIV="" F S DIV=$O(^TMP($J,"ECXAUD",DIV)) Q:DIV="" D Q:QFLG
  1. .D:'$G(ECXPORT) HEADER S TOT("D")=0 ;149
  1. .S ECFL="" F S ECFL=$O(^TMP($J,"ECXAUD",DIV,ECFL)) Q:ECFL="" S TYPE=+$P(ECFL,"-",2) D Q:QFLG
  1. ..S TYPENM=$P($G(TYPE(TYPE)),U,1),TYPENM=$E(TYPENM,1,18),TOT("FL")=0
  1. ..S ECFK="" F S ECFK=$O(^TMP($J,"ECXAUD",DIV,ECFL,ECFK)) Q:ECFK="" S TOT=^(ECFK) D Q:QFLG
  1. ...I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,ECFL,?43,ECFK,?68,$$RJ^XLFSTR(TOT,5," ") ;149
  1. ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=ECXEXT_U_$P($G(ECXDIV(DIV)),U,2)_"("_$P($G(ECXDIV(DIV)),U)_")"_U_ECFL_" ("_TYPENM_")"_U_ECFK_U_TOT,CNT=CNT+1 ;149
  1. ...S TOT("FL")=TOT("FL")+TOT,TOT("D")=TOT("D")+TOT
  1. ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^Total for Feeder Location "_DIV_"-"_TYPENM_" ("_ECFL_")^^"_TOT("FL"),CNT=CNT+1,^TMP($J,"ECXPORT",CNT)="^",CNT=CNT+1 ;149
  1. ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,?40,$E(LN,1,34) ;149
  1. ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,"Total for Feeder Location "_DIV_"-"_TYPENM_" ("_ECFL_"):",?68,$$RJ^XLFSTR(TOT("FL"),5," ") ;149
  1. .I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^Grand Total for Division "_DIV_"^^"_TOT("D"),CNT=CNT+1,^TMP($J,"ECXPORT",CNT)="^" ;149
  1. .I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Grand Total for Division "_DIV_":",?68,$$RJ^XLFSTR(TOT("D"),5," ") ;149
  1. ;close
  1. I $G(ECXPORT) Q ;149
  1. I $E(IOST)'="C" W @IOF
  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
  1. D AUDIT^ECXKILL
  1. Q
  1. D SASHEAD^ECXUTLA(DIV,ECXHEAD,.ECXDIV,.ECXARRAY,.PG)
  1. Q