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

ECXSARXS.m

Go to the documentation of this file.
  1. ECXSARXS ;BIR/DMA-SAS Report from Prescription Extract; 22 Sep 95 / 10:27 AM ;3/27/14 16:11
  1. ;;3.0;DSS EXTRACTS;**8,149**;Dec 22, 1997;Build 27
  1. ;
  1. EN ;entry point from menu option
  1. N ECXPORT,CNT ;149
  1. W @IOF,!!,"Prescription Extract SAS Report",!!
  1. ;ecxaud=1 for 'sas' audit
  1. S ECXHEAD="PRE",ECXAUD=1
  1. ;select extract
  1. D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
  1. I ECXERR D AUDIT^ECXKILL Q
  1. ;select all pharmacy sites/divisions
  1. S ECXALL=1 D PRE^ECXDVSN1(.ECXDIV,ECXALL,.ECXERR)
  1. I ECXERR D AUDIT^ECXKILL Q
  1. S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Secition 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^ECXSARXS",ECXDESC="Prescription 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,X,Y,JJ,SS,LN,PG,DIV,EC,ECFK,ECFL,ECQ,MAIL,NEWRX,COPAY,DEA,TOT,QFLG,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. ;process the extract records
  1. S J="" F S J=$O(^ECX(727.81,"AC",ECXEXT,J)) Q:'J I $D(^ECX(727.81,J,0)) S EC=^(0) D
  1. .S DIV=$P(EC,U,10),MAIL=+$P(EC,U,13),NEWRX=+$P(EC,U,15),COPAY=+$P(EC,U,27),DEA=$P(EC,U,29)
  1. .;non-cmop rxs only
  1. .;feeder location is always "pre"_div
  1. .I MAIL'=2 D
  1. ..S ECFL="PRE"_DIV,ECFK=$P(EC,U,28),ECQ=+$P(EC,U,17)
  1. ..S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ..;additional feeder key records for non-cmop rx
  1. ..S ECFK="BASIC",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ..I MAIL=1 D
  1. ...S ECFK="VAMAIL",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ...I NEWRX=1 D
  1. ....S ECFK="NEWVMOP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ..I MAIL=0&(NEWRX=1) D
  1. ...S ECFK="NEWWIN",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ..I COPAY=1 D
  1. ...S ECFK="COPAY",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ..I DEA="I" D
  1. ...S ECFK="PREDEASP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. .;cmop rxs only
  1. .;feeder location is "cmopdsu"_div, "cmopdis"_div, and also "pre"_div
  1. .I MAIL=2 D
  1. ..S ECFL="CMOPDSU"_DIV,ECFK=$P(EC,U,28),ECQ=+$P(EC,U,17),^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ..S ECFL="CMOPDIS"_DIV,ECFK="CMOPDISP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ..S ECFL="PRE"_DIV D
  1. ...;possibly three additional feeder key recods for cmop rx
  1. ...I NEWRX=1 D
  1. ....S ECFK="NEWCMOP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ...I COPAY=1 D
  1. ....S ECFK="COPAY",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ...I DEA="I" D
  1. ....S ECFK="PREDEASP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ
  1. ;print the report
  1. U IO
  1. S DIV="" F S DIV=$O(^TMP($J,"ECXAUD",DIV)) Q:DIV="" D Q:QFLG
  1. .I '$G(ECXPORT) D HEADER ;149
  1. .S ECFL="" F S ECFL=$O(^TMP($J,"ECXAUD",DIV,ECFL)) Q:ECFL="" D Q:QFLG
  1. ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,ECFL ;149
  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) S ^TMP($J,"ECXPORT",CNT)=ECXEXT_U_$P($G(ECXDIV(DIV)),U,2)_"("_$P($G(ECXDIV(DIV)),U)_")"_U_ECFL_U_ECFK_U_TOT,CNT=CNT+1 Q ;149
  1. ...D:($Y+3>IOSL) HEADER Q:QFLG W ?40,ECFK,?68,$$RJ^XLFSTR(TOT,5," "),!
  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. ;
  1. D SASHEAD^ECXUTLA(DIV,ECXHEAD,.ECXDIV,.ECXARRAY,.PG)
  1. Q