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