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

ECXAPHA.m

Go to the documentation of this file. 
  1. ECXAPHA ;ALB/TMD-Pharmacy Extracts Unusual Volumes/Costs Report ;5/31/17  16:18
  1.  ;;3.0;DSS EXTRACTS;**40,49,66,104,109,113,136,144,154,166,178,184,187**;Dec 22, 1997;Build 163
  1.  ;
  1.  ; Reference to EN^XUTMDEVQ in ICR #1519
  1.  ; Reference to ^TMP($J supported by SACC 2.3.2.5.1
  1.  ;
  1. EN ; entry point
  1.  N X,Y,DATE,ECRUN,ECXOPT,ECXDESC,ECXSAVE,ECXTL,ECTHLD,ECSD
  1.  N ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXISIG,FYVER,ECXBCM,ECXPORT,CNT ;144
  1.  S QFLG=0
  1.  ; get today's date
  1.  D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
  1.  D BEGIN Q:QFLG
  1.  D SELECT Q:QFLG!($G(FYVER)=-1)  ;144 Quit if selections not made for report
  1.  I '$G(ECXCOST) I ECXOPT=2 I FYVER'="" D @(FYVER) Q  ;144 Run previous version of routine and quit if it's the volume report
  1.  S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1  I ECXPORT D  Q  ;144
  1.  .K ^TMP($J) ;144
  1.  .S ^TMP($J,"ECXPORT",0)="NAME^SSN^DAY^GENERIC NAME^FEEDER KEY^"_$S(ECXOPT=1!(ECXOPT=3):"QUANTITY",ECXOPT=2:"TOTAL DOSES PER DAY",1:"COMPONENT DOSE GIVEN")_"^TOTAL COST"_$S(ECXOPT=1:"^DAYS SUPPLY",1:"")_$S(ECXISIG:"^SIG",1:"") ;144 ;178
  1.  .S ^TMP($J,"ECXPORT",0)=^(0)_"^DISPENSE UNIT^PRICE PER DISPENSE UNIT" ;187
  1.  .S ^TMP($J,"ECXPORT",0)=^TMP($J,"ECXPORT",0)_$S(ECXOPT=4:"^ORDERED DOSAGE^PRICE PER ORDER UNIT^DISPENSE UNITS PER ORDER UNIT",1:"") ;184
  1.  .S CNT=1 ;144
  1.  .D PROCESS ;144
  1.  .D EXPDISP^ECXUTL1 ;144
  1.  .D AUDIT^ECXKILL ;144
  1.  S ECXDESC=ECXTL_" Pre-Extract Unusual"_$S($G(ECXCOST):" Cost",1:" Volume")_" Report" ;144,166 tjl - Changed report title
  1.  S ECXSAVE("EC*")=""
  1.  W !!,"This report requires 132-column format."
  1.  D EN^XUTMDEVQ("PROCESS^ECXAPHA",ECXDESC,.ECXSAVE)
  1.  I POP W !!,"No device selected...exiting.",! Q
  1.  I IO'=IO(0) D ^%ZISC
  1.  D HOME^%ZIS
  1.  D AUDIT^ECXKILL
  1.  Q
  1.  ;
  1. BEGIN ; display report description
  1.  W @IOF
  1.  W !,"This report prints a listing of unusual ",$S('$G(ECXCOST):"volumes",1:"costs")," that would be" ;144
  1.  ;W !,"generated by the pharmacy extracts (PRE, IVP"_$S('$G(ECXCOST):", UDP and BCM)",1:" and UDP)")_" as" ;154 Don't show BCM if cost report
  1.  W !,"generated by the pharmacy extracts (PRE, IVP, UDP and BCM)" ;154 Don't show BCM if cost report,184 - Include BCM for the Cost Report
  1.  W !,"determined by a user defined threshold value.  It should be run" ;144 Corrected spelling of should
  1.  W !,"prior to the generation of the actual extract(s) to identify and"
  1.  W !,"fix as necessary any ",$S('$G(ECXCOST):"volumes",1:"costs")," determined to be erroneous." ;144
  1.  I '$G(ECXCOST) D  ;144
  1.  .W !!,"Unusual volumes are defined as follows:" ;144
  1.  .W !!,"PRE Extract:  Quantity field greater than the threshold value." ;144
  1.  .W !,"IVP Extract:  Total Doses Per Day field greater than the threshold" ;144
  1.  .W !,?14,"or less than the negative of the threshold value." ;144
  1.  .W !,"UDP Extract:  Quantity field greater than threshold value." ;144
  1.  .W !,"BCM Extract:  Component Dose Given field greater than threshold value." ;144
  1.  W !!,"Note: The threshold can be set after a report is selected."
  1.  W !!,"Run times for this report will vary depending upon the size of"
  1.  W !,"the extract and could take as long as 30 minutes or more to"
  1.  W !,"complete.  This report has no effect on the actual extracts and"
  1.  W !,"can be run as needed."
  1.  W !!,"The report is sorted by Feeder Key, Descending ",$S('$G(ECXCOST):"Volume",1:"Cost"),", and SSN."
  1.  S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
  1.  W:$Y!($E(IOST)="C") @IOF,!!
  1.  Q
  1.  ;
  1. SELECT ; user inputs for report option, threshold volume/cost and date range
  1.  N DONE,OUT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT ;144
  1.  S ECXISIG=0,ECXBCM="" ;144
  1.  ; allow user to select report option (PRE,IVP,UDP or BCM if volume report)
  1.  W "Choose the report you would like to run."
  1.  ;S DIR(0)="S^1:PRE;2:IVP;3:UDP"_$S('$G(ECXCOST):";4:BCM",1:""),DIR("A")="Selection",DIR("B")=1 D ^DIR K DIR S ECXOPT=Y I X["^" S QFLG=1 Q  ;154 Only show BCM if volume report
  1.  S DIR(0)="S^1:PRE;2:IVP;3:UDP;4:BCM",DIR("A")="Selection",DIR("B")=1 D ^DIR K DIR S ECXOPT=Y I X["^" S QFLG=1 Q  ;184 - Added BCM to the Unusual Cost Report
  1.  I '$G(ECXCOST) I ECXOPT=2 S FYVER=$$REPORTFY^ECXUTL1("RXUNVOL") Q:FYVER=-1  ;144 Which version of report should be run for volume report?
  1.  I ECXOPT=4 D  Q:$G(QFLG)  ;144
  1.  .S DIR(0)="S^I:IV;N:NON-IV",DIR("A")="Select type of BCM record",DIR("?",1)="BCM contains both IV and NON-IV records.  Select which type of",DIR("?")="record to check against the threshold." ;144
  1.  .D ^DIR S:$D(DIRUT) QFLG=1 I '$G(QFLG) S ECXBCM=Y ;144
  1.  S ECXTL=$S(ECXOPT=1:"Prescription",ECXOPT=2:"IV Detail",ECXOPT=3:"Unit Dose Local",ECXOPT=4:"BCM-"_$S(ECXBCM="N":"NON ",1:"")_"IV Entries",1:"") ;144
  1.  ; allow user to set threshold volume/cost
  1.  I '$G(ECXCOST) S ECTHLD=$S(ECXOPT=2!(ECXOPT=4&(ECXBCM="I")):1000,ECXOPT=4&(ECXBCM="N"):5,1:500) ;144
  1.  ;I $G(ECXCOST) S ECTHLD=$S(ECXOPT=2!(ECXOPT=4&(ECXBCM="I")):100,ECXOPT=3!(ECXOPT=4&(ECXBCM="N")):20,1:50) ;144
  1.  I $G(ECXCOST) S ECTHLD=$S(ECXOPT=2:100,ECXOPT=1:50,1:20) ;184
  1.  W !!,"The default threshold ",$S('$G(ECXCOST):"volume",1:"cost")," for the ",ECXTL," extract is ",$S($G(ECXCOST):"$",1:""),ECTHLD,"." ;144
  1.  S DIR(0)="Y",DIR("A")="Would you like to change the threshold",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q
  1.  I Y D
  1.  .I '$G(ECXCOST) W !!,$S(ECXOPT=2:"threshold > Total Doses Per Day < -threshold",ECXOPT=4:"Component Dose Give > Threshold",1:"Quantity > threshold") ;144
  1.  .S DIR(0)="N^0:100000:0",DIR("A")="Enter the new threshold "_$S('$G(ECXCOST):"volume",1:"cost") D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q  ;144
  1.  ; check to see if SIG should be place on the sec line of rpt cvw - *136 
  1.  ;I ECXOPT=3!(ECXOPT=4&(ECXBCM="N")) S DIR(0)="Y",DIR("A")="Include SIG/Order Direction on line 2 of report",DIR("B")="NO" D ^DIR K DIR S:Y ECXISIG=1 I X["^" S QFLG=1 Q  ;144
  1.  ;I ($G(ECXCOST)&(ECXOPT=3))!('$G(ECXCOST)) S DIR(0)="Y",DIR("A")="Include SIG/Order Direction on line 2 of report",DIR("B")="NO" D ^DIR K DIR S:Y ECXISIG=1 I X["^" S QFLG=1 Q  ;144  ;178 
  1.  I ($G(ECXCOST)&($F("3,4",ECXOPT)))!('$G(ECXCOST)) D  ;184
  1.  .S DIR(0)="Y",DIR("A")="Include SIG/Order Direction on line 2 of report",DIR("B")="NO" D ^DIR K DIR S:Y ECXISIG=1 I X["^" S QFLG=1 Q  ;144  ;178; 184 - Added SIG to the Unusual Cost Report for BCM
  1.  ; get date range from user
  1.  W !!,"Enter the date range for which you would like to scan the ",ECXTL,!,"Extract records."
  1.  S DONE=0 F  S (ECED,ECSD)="" D  Q:QFLG!DONE
  1.  .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT
  1.  .I Y<0 S QFLG=1 Q
  1.  .S ECSD=Y,ECSD1=ECSD-.1
  1.  .D DD^%DT S ECSTART=Y
  1.  .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT
  1.  .I Y<0 S QFLG=1 Q
  1.  .I Y<ECSD D  Q
  1.  ..W !!,"The ending date cannot be earlier than the starting date."
  1.  ..W !,"Please try again.",!!
  1.  .I $E(Y,1,5)'=$E(ECSD,1,5) D  Q
  1.  ..W !!,"Beginning and ending dates must be in the same month and year."
  1.  ..W !,"Please try again.",!!
  1.  .S ECED=Y
  1.  .D DD^%DT S ECEND=Y
  1.  .S DONE=1
  1.  Q
  1.  ;
  1. PROCESS ; entry point for queued report
  1.  S ZTREQ="@"
  1.  S ECXERR=0 D EN^ECXAPHA2 Q:ECXERR
  1.  S QFLG=0 D PRINT
  1.  Q
  1.  ;
  1. PRINT ; process temp file and print report
  1.  N PG,QFLG,GTOT,LN,COUNT,FKEY,QTY,SSN,REC,EDAY,ECXCOUNT
  1.  U IO
  1.  I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
  1.  S (PG,QFLG,GTOT)=0,$P(LN,"-",132)=""
  1.  I '$G(ECXPORT) D HEADER Q:QFLG  ;144
  1.  S COUNT=0,FKEY="" F  S FKEY=$O(^TMP($J,FKEY)) Q:FKEY=""!QFLG!(FKEY="ECXPORT")  D  ;144
  1.  .S QTY="" F  S QTY=$O(^TMP($J,FKEY,QTY)) Q:QTY=""!QFLG  D
  1.  ..S EDAY="" F  S EDAY=$O(^TMP($J,FKEY,QTY,EDAY)) Q:EDAY=""!QFLG  D
  1.  ...S ECXCOUNT="" F  S ECXCOUNT=$O(^TMP($J,FKEY,QTY,EDAY,ECXCOUNT)) Q:ECXCOUNT=""!QFLG  D
  1.  ....S SSN=""
  1.  ....F  S SSN=$O(^TMP($J,FKEY,QTY,EDAY,ECXCOUNT,SSN)) Q:SSN=""!QFLG  S REC=^(SSN)  D
  1.  .....I $G(ECXPORT) D  Q  ;144
  1.  ......;S ^TMP($J,"ECXPORT",CNT)=$P(REC,U)_U_$P(REC,U,2)_U_$P(REC,U,3)_U_$P(REC,U,4)_U_$P(REC,U,5)_U_$P(REC,U,6)_" "_$P(REC,U,7)_U_$P(REC,U,8)_$S(ECXOPT=1:(U_$P(REC,U,9)),ECXISIG:(U_$S($P(REC,U,10)="":"N/A",1:$P(REC,U,10))),1:"") ;144
  1.  ......S ^TMP($J,"ECXPORT",CNT)=$P(REC,U)_U_$P(REC,U,2)_U_$P(REC,U,3)_U_$P(REC,U,4)_U_$P(REC,U,5)_U_$P(REC,U,6)_" "_$P(REC,U,7)_U_$P(REC,U,8)_$S(ECXOPT=1:(U_$P(REC,U,9)),1:"") ;144 ; 178
  1.  ......S ^TMP($J,"ECXPORT",CNT)=^TMP($J,"ECXPORT",CNT)_$S(ECXISIG:(U_$S($P(REC,U,10)="":"N/A",1:$P(REC,U,10))),1:"") ;144; 178
  1.  ......S ^TMP($J,"ECXPORT",CNT)=^TMP($J,"ECXPORT",CNT)_U_$P(REC,U,7)_U_$P(REC,U,11) ;187
  1.  ......;I ECXOPT=4 S ^TMP($J,"ECXPORT",CNT)=^TMP($J,"ECXPORT",CNT)_U_$P(REC,U,11)_U_$P(REC,U,12)_U_$P(REC,U,13)_U_$P(REC,U,14)_U_$P(REC,U,15) ;184
  1.  ......I ECXOPT=4=$S(ECXISIG:$P(^TMP($J,"ECXPORT",CNT),U,1,9),1:$P(^TMP($J,"ECXPORT",CNT),U,1,8))_U_$P(REC,U,11,14) ;184, 187
  1.  ......S CNT=CNT+1 ;144
  1.  .....S COUNT=COUNT+1
  1.  .....I $Y+3>IOSL D HEADER Q:QFLG
  1.  .....W !,$P(REC,U),?8,$P(REC,U,2),?20,$P(REC,U,3),?29,$E($P(REC,U,4),1,40)
  1.  .....W ?71,$P(REC,U,5),?89,$$RJ^XLFSTR($P(REC,U,6),9)_" "_$E($P(REC,U,7),1,7)
  1.  .....I ECXOPT=1 D
  1.  ......W ?108,$$RJ^XLFSTR($P(REC,U,8),12),?125,$$RJ^XLFSTR($P(REC,U,9),3)
  1.  .....I ECXOPT'=1 D
  1.  ......W ?116,$$RJ^XLFSTR($P(REC,U,8),14)
  1.  .....I $G(ECXISIG) D  ;144
  1.  ......W !,?5,"SIG: ",$S($P(REC,U,10)="":"N/A",1:$P(REC,U,10)),! ;136
  1.  Q:QFLG!($G(ECXPORT))  ;144
  1.  I COUNT=0 W !!,?8,"No unusual ",$S('$G(ECXCOST):"volumes",1:"costs")," to report for this extract" ;144
  1. CLOSE ;
  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.  Q
  1.  ;
  1.  N SS,JJ
  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 !,ECXTL_" Pre-Extract Unusual ",$S('$G(ECXCOST):"Volume",1:"Cost")," Report",?124,"Page: "_PG ;144,166 tjl - Changed report title
  1.  W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time:  "_ECRUN
  1.  W !,"End Date:   ",ECEND,?97,"Threshold Value = ",$S($G(ECXCOST):"$",1:""),ECTHLD ;144
  1.  W !!,"Name",?11,"SSN",?21,"Day",?29,"Generic Name",?71,"Feeder Key"
  1.  I ECXOPT=1 W ?95,"Quantity",?109,"Total Cost",?120,"Days Supply" ;144 Combined lines
  1.  I ECXOPT=2 W ?93,"Total Doses",?121,"Total Cost",!,?95,"Per Day" ;144
  1.  I ECXOPT=3 W ?96,"Quantity",?121,"Total Cost" ;144
  1.  I ECXOPT=4 W ?89,"Component Dose Given",?121,"Total Cost" ;144
  1.  W !,LN,!
  1.  Q
  1.  ;
  1. SIG(ORDNO,PATNO) ;Get ordering instructions for unit dose order.  API added in patch 136
  1.  N DATA,RECNO,I,SIG
  1.  S SIG=""
  1.  I ORDNO=""!(PATNO="") Q SIG
  1.  S RECNO=ORDNO_","_PATNO_","
  1.  D GETS^DIQ(55.06,RECNO,"26;120;121","E","DATA")
  1.  F I=120,121,26 S SIG=$G(SIG)_$S($L(SIG)>0:" ",1:"")_$G(DATA(55.06,RECNO,I,"E"))
  1.  Q SIG
  1.  ;
  1. COST ;Section added in 144, entry point for unusual cost report
  1.  N ECXCOST
  1.  S ECXCOST=1
  1.  D EN
  1.  Q
  1. SIGPRE(ORDNO) ;Get SIG for Prescription Order - 178
  1.  N DATA,SIG,RECNO,I,EXPREIEN
  1.  S (I,SIG,LIST)=""
  1.  S ECPREIEN=$O(^PSRX("B",ORDNO,"")) I ECPREIEN="" Q SIG
  1.  S RECNO=ECPREIEN_","
  1.  D GETS^DIQ(52,RECNO,"10.2*","","DATA")
  1.  F  S LIST=$O(DATA(52.04,LIST)) Q:LIST=""  S STR=DATA(52.04,LIST,.01)_" ",SIG=SIG_STR
  1.  Q SIG
  1. SIGIVP(ORDNO,PATNO) ;Get SIG for IV Order - 178
  1.  N DATA,RECNO,I,SIG
  1.  S SIG=""
  1.  I ORDNO=""!(PATNO="") Q SIG
  1.  S RECNO=ORDNO_","_PATNO_","
  1.  D GETS^DIQ(55.01,RECNO,".09;131","","DATA")
  1.  F I=131,.09 S SIG=$G(SIG)_$S($L(SIG)>0:" ",1:"")_$G(DATA(55.01,RECNO,I))
  1.  Q SIG