| 1 | ECXSARAD ;BIR/DMA-SAS Report from Radiology Extract; 25 Apr 95 / 11:03 AM
|
|---|
| 2 | ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
|
|---|
| 3 | EN ;entry point from menu option
|
|---|
| 4 | W @IOF,!!,"Radiology Extract SAS Report",!!
|
|---|
| 5 | ;ecxaud=1 for 'sas' audit
|
|---|
| 6 | S ECXHEAD="RAD",ECXAUD=1
|
|---|
| 7 | ;select extract
|
|---|
| 8 | D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
|
|---|
| 9 | I ECXERR D AUDIT^ECXKILL Q
|
|---|
| 10 | ;select all radiology sites/divisions
|
|---|
| 11 | S ECXALL=1 D RAD^ECXDVSN2(.ECXDIV,ECXALL,.ECXERR)
|
|---|
| 12 | I ECXERR D AUDIT^ECXKILL Q
|
|---|
| 13 | W !!
|
|---|
| 14 | S ECXPGM="PROCESS^ECXSARAD",ECXDESC="Radiology Extract SAS Report"
|
|---|
| 15 | S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")=""
|
|---|
| 16 | W !
|
|---|
| 17 | D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
|
|---|
| 18 | I ECXSAVE("POP")=1 D Q
|
|---|
| 19 | .W !!,?5,"Try agian later... exiting.",!
|
|---|
| 20 | .D AUDIT^ECXKILL
|
|---|
| 21 | I ECXSAVE("ZTSK")=0 D
|
|---|
| 22 | .K ECXSAVE,ECXPGM,ECXDESC
|
|---|
| 23 | .D PROCESS
|
|---|
| 24 | I IO'=IO(0) D ^%ZISC
|
|---|
| 25 | D HOME^%ZIS
|
|---|
| 26 | D AUDIT^ECXKILL
|
|---|
| 27 | Q
|
|---|
| 28 | ;
|
|---|
| 29 | PROCESS ;queued entry
|
|---|
| 30 | N J,K,X,Y,JJ,SS,LN,PG,DIV,EC,ECFK,ECFL,QFLG,TOT,TYPE,TYPENM,DIQ,DR,DA,DIR,DIRUT,DTOUT,DUOUT
|
|---|
| 31 | K ^TMP($J,"ECXAUD")
|
|---|
| 32 | S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
|
|---|
| 33 | S (QFLG,PG)=0,$P(LN,"-",80)=""
|
|---|
| 34 | ;get run date in external format
|
|---|
| 35 | D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
|
|---|
| 36 | ;setup array of imaging types
|
|---|
| 37 | S TYPE=0 F S TYPE=$O(^RA(79.2,TYPE)) Q:+TYPE<1 D
|
|---|
| 38 | .K ECX S DIC="^RA(79.2,",DR=".01;3",DIQ="ECX",DIQ(0)="I",DA=TYPE D EN^DIQ1
|
|---|
| 39 | .S TYPE(TYPE)=ECX(79.2,TYPE,.01,"I")_U_ECX(79.2,TYPE,3,"I")
|
|---|
| 40 | ;process the extract records
|
|---|
| 41 | 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
|
|---|
| 42 | .S ECFK=$P(EC,U,10) I ECFK="" S ECFK=$P(EC,U,11)
|
|---|
| 43 | .I $P(EC,U,10)="",$P(EC,U,11)=468 S ECFK=777777
|
|---|
| 44 | .S MODS=";"_$P(EC,U,17)_";"
|
|---|
| 45 | .S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+1
|
|---|
| 46 | .I MODS[";1;" S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+1
|
|---|
| 47 | .I MODS[";2;" S ^(888888)=$G(^TMP($J,"ECXAUD",DIV,ECFL,888888))+1
|
|---|
| 48 | .I MODS[";3;" S ^(999999)=$G(^TMP($J,"ECXAUD",DIV,ECFL,999999))+1
|
|---|
| 49 | ;print the report
|
|---|
| 50 | U IO
|
|---|
| 51 | S DIV="" F S DIV=$O(^TMP($J,"ECXAUD",DIV)) Q:DIV="" D Q:QFLG
|
|---|
| 52 | .D HEADER S TOT("D")=0
|
|---|
| 53 | .S ECFL="" F S ECFL=$O(^TMP($J,"ECXAUD",DIV,ECFL)) Q:ECFL="" S TYPE=+$P(ECFL,"-",2) D Q:QFLG
|
|---|
| 54 | ..S TYPENM=$P($G(TYPE(TYPE)),U,1),TYPENM=$E(TYPENM,1,18),TOT("FL")=0
|
|---|
| 55 | ..S ECFK="" F S ECFK=$O(^TMP($J,"ECXAUD",DIV,ECFL,ECFK)) Q:ECFK="" S TOT=^(ECFK) D Q:QFLG
|
|---|
| 56 | ...D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,ECFL,?43,ECFK,?68,$$RJ^XLFSTR(TOT,5," ")
|
|---|
| 57 | ...S TOT("FL")=TOT("FL")+TOT,TOT("D")=TOT("D")+TOT
|
|---|
| 58 | ..D:($Y+3>IOSL) HEADER Q:QFLG W !,?40,$E(LN,1,34)
|
|---|
| 59 | ..D:($Y+3>IOSL) HEADER Q:QFLG W !,"Total for Feeder Location "_DIV_"-"_TYPENM_" ("_ECFL_"):",?68,$$RJ^XLFSTR(TOT("FL"),5," ")
|
|---|
| 60 | .D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Grand Total for Division "_DIV_":",?68,$$RJ^XLFSTR(TOT("D"),5," ")
|
|---|
| 61 | ;close
|
|---|
| 62 | I $E(IOST)'="C" W @IOF
|
|---|
| 63 | I $E(IOST)="C",'QFLG D
|
|---|
| 64 | .S SS=22-$Y F JJ=1:1:SS W !
|
|---|
| 65 | .S DIR(0)="E" W ! D ^DIR K DIR
|
|---|
| 66 | D AUDIT^ECXKILL
|
|---|
| 67 | Q
|
|---|
| 68 | HEADER ;print the header
|
|---|
| 69 | D SASHEAD^ECXUTLA(DIV,ECXHEAD,.ECXDIV,.ECXARRAY,.PG)
|
|---|
| 70 | Q
|
|---|
