ECXAPHAP ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ;6/1/17 15:46
;;3.0;DSS EXTRACTS;**40,49,66,104,109,113,136,144,166**;Dec 22, 1997;Build 24
;
;This routine is new with patch 144 but is a copy of ECXAPHA before it
;was changed for the FY update. This is now the previous fiscal year
;version of the routine
EN ; entry point
N X,Y,DATE,ECRUN,ECXOPT,ECXDESC,ECXSAVE,ECXTL,ECTHLD,ECSD
N ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXISIG
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
PREV ;Line label added in patch 144. Come here when running previous fiscal year logic for this report
S ECXDESC=ECXTL_" Pre-Extract Unusual Volume Report" ;tjl 166 Changed report title
S ECXSAVE("EC*")=""
W !!,"This report requires 132-column format."
D EN^XUTMDEVQ("PROCESS^ECXAPHAP",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 volumes that would be"
W !,"generated by the pharmacy extracts (PRE, IVP and UDP) as"
W !,"determined by a user defined threshold value. It shoud be run"
W !,"prior to the generation of the actual extract(s) to identify and"
W !,"fix as necessary any volumes determined to be erroneous."
W !!,"Unusual volumes are defined as follows:"
W !!,"PRE Extract: Quantity field greater than the threshold value."
W !,"IVP Extract: Total Doses Per Day field greater than the threshold"
W !,?14,"or less than the negative of the threshold value."
W !,"UDP Extract: Quantity field greater than threshold value."
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 Volume, 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 and date range
N DONE,OUT
S ECXISIG=0
; allow user to select report option (PRE,IVP or UDP)
W "Choose the report you would like to run."
S DIR(0)="S^1:PRE;2:IVP;3:UDP",DIR("A")="Selection",DIR("B")=1 D ^DIR K DIR S ECXOPT=Y I X["^" S QFLG=1 Q
S ECXTL=$S(ECXOPT=1:"Prescription",ECXOPT=2:"IV Detail",ECXOPT=3:"Unit Dose Local",1:"")
; allow user to set threshold volume
S ECTHLD=$S(ECXOPT=2:1000,1:500)
W !!,"The default threshold volume for the ",ECXTL," extract is ",ECTHLD,"."
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
.W !!,$S(ECXOPT=2:"threshold > Total Doses Per Day < -threshold",1:"Quantity > threshold")
.S DIR(0)="N^0:100000:0",DIR("A")="Enter the new threshold volume" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q
; check to see if SIG should be place on the sec line of rpt cvw - *136
I ECXOPT=3 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
; 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^ECXAPHP2 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)=""
D HEADER Q:QFLG
S COUNT=0,FKEY="" F S FKEY=$O(^TMP($J,FKEY)) Q:FKEY=""!QFLG D
.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
.....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 ECXOPT=3&($G(ECXISIG)) D
......W !,?5,"SIG: ",$S($P(REC,U,10)="":"N/A",1:$P(REC,U,10)),! ;136
Q:QFLG
I COUNT=0 W !!,?8,"No unusual volumes to report for this extract"
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 Volume Report - Previous FY logic",?124,"Page: "_PG ;tjl 166 Changed report title
W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN
W !,"End Date: ",ECEND,?97,"Threshold Value = ",ECTHLD
W !!,"Name",?11,"SSN",?21,"Day",?29,"Generic Name",?71,"Feeder Key"
I ECXOPT=1 D
.W ?95,"Quantity",?109,"Total Cost",?120,"Days Supply"
E D
.I ECXOPT=2 W ?93,"Total Doses",?121,"Total Cost",!,?95,"Per Day"
.I ECXOPT'=2 W ?96,"Quantity",?121,"Total Cost"
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXAPHAP 6435 printed Nov 22, 2024@17:02:17 Page 2
ECXAPHAP ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ;6/1/17 15:46
+1 ;;3.0;DSS EXTRACTS;**40,49,66,104,109,113,136,144,166**;Dec 22, 1997;Build 24
+2 ;
+3 ;This routine is new with patch 144 but is a copy of ECXAPHA before it
+4 ;was changed for the FY update. This is now the previous fiscal year
+5 ;version of the routine
EN ; entry point
+1 NEW X,Y,DATE,ECRUN,ECXOPT,ECXDESC,ECXSAVE,ECXTL,ECTHLD,ECSD
+2 NEW ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXISIG
+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 DO SELECT
if QFLG
QUIT
PREV ;Line label added in patch 144. Come here when running previous fiscal year logic for this report
+1 ;tjl 166 Changed report title
SET ECXDESC=ECXTL_" Pre-Extract Unusual Volume Report"
+2 SET ECXSAVE("EC*")=""
+3 WRITE !!,"This report requires 132-column format."
+4 DO EN^XUTMDEVQ("PROCESS^ECXAPHAP",ECXDESC,.ECXSAVE)
+5 IF POP
WRITE !!,"No device selected...exiting.",!
QUIT
+6 IF IO'=IO(0)
DO ^%ZISC
+7 DO HOME^%ZIS
+8 DO AUDIT^ECXKILL
+9 QUIT
+10 ;
BEGIN ; display report description
+1 WRITE @IOF
+2 WRITE !,"This report prints a listing of unusual volumes that would be"
+3 WRITE !,"generated by the pharmacy extracts (PRE, IVP and UDP) as"
+4 WRITE !,"determined by a user defined threshold value. It shoud be run"
+5 WRITE !,"prior to the generation of the actual extract(s) to identify and"
+6 WRITE !,"fix as necessary any volumes determined to be erroneous."
+7 WRITE !!,"Unusual volumes are defined as follows:"
+8 WRITE !!,"PRE Extract: Quantity field greater than the threshold value."
+9 WRITE !,"IVP Extract: Total Doses Per Day field greater than the threshold"
+10 WRITE !,?14,"or less than the negative of the threshold value."
+11 WRITE !,"UDP Extract: Quantity field greater than threshold value."
+12 WRITE !!,"Note: The threshold can be set after a report is selected."
+13 WRITE !!,"Run times for this report will vary depending upon the size of"
+14 WRITE !,"the extract and could take as long as 30 minutes or more to"
+15 WRITE !,"complete. This report has no effect on the actual extracts and"
+16 WRITE !,"can be run as needed."
+17 WRITE !!,"The report is sorted by Feeder Key, descending Volume, and SSN."
+18 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
QUIT
+19 if $Y!($EXTRACT(IOST)="C")
WRITE @IOF,!!
+20 QUIT
+21 ;
SELECT ; user inputs for report option, threshold volume and date range
+1 NEW DONE,OUT
+2 SET ECXISIG=0
+3 ; allow user to select report option (PRE,IVP or UDP)
+4 WRITE "Choose the report you would like to run."
+5 SET DIR(0)="S^1:PRE;2:IVP;3:UDP"
SET DIR("A")="Selection"
SET DIR("B")=1
DO ^DIR
KILL DIR
SET ECXOPT=Y
IF X["^"
SET QFLG=1
QUIT
+6 SET ECXTL=$SELECT(ECXOPT=1:"Prescription",ECXOPT=2:"IV Detail",ECXOPT=3:"Unit Dose Local",1:"")
+7 ; allow user to set threshold volume
+8 SET ECTHLD=$SELECT(ECXOPT=2:1000,1:500)
+9 WRITE !!,"The default threshold volume for the ",ECXTL," extract is ",ECTHLD,"."
+10 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
+11 IF Y
Begin DoDot:1
+12 WRITE !!,$SELECT(ECXOPT=2:"threshold > Total Doses Per Day < -threshold",1:"Quantity > threshold")
+13 SET DIR(0)="N^0:100000:0"
SET DIR("A")="Enter the new threshold volume"
DO ^DIR
KILL DIR
SET ECTHLD=Y
IF X["^"
SET QFLG=1
QUIT
End DoDot:1
+14 ; check to see if SIG should be place on the sec line of rpt cvw - *136
+15 IF ECXOPT=3
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
+16 ; get date range from user
+17 WRITE !!,"Enter the date range for which you would like to scan the ",ECXTL,!,"Extract records."
+18 SET DONE=0
FOR
SET (ECED,ECSD)=""
Begin DoDot:1
+19 KILL %DT
SET %DT="AEX"
SET %DT("A")="Starting with Date: "
SET %DT(0)=-DATE
DO ^%DT
+20 IF Y<0
SET QFLG=1
QUIT
+21 SET ECSD=Y
SET ECSD1=ECSD-.1
+22 DO DD^%DT
SET ECSTART=Y
+23 KILL %DT
SET %DT="AEX"
SET %DT("A")="Ending with Date: "
SET %DT(0)=-DATE
DO ^%DT
+24 IF Y<0
SET QFLG=1
QUIT
+25 IF Y<ECSD
Begin DoDot:2
+26 WRITE !!,"The ending date cannot be earlier than the starting date."
+27 WRITE !,"Please try again.",!!
End DoDot:2
QUIT
+28 IF $EXTRACT(Y,1,5)'=$EXTRACT(ECSD,1,5)
Begin DoDot:2
+29 WRITE !!,"Beginning and ending dates must be in the same month and year."
+30 WRITE !,"Please try again.",!!
End DoDot:2
QUIT
+31 SET ECED=Y
+32 DO DD^%DT
SET ECEND=Y
+33 SET DONE=1
End DoDot:1
if QFLG!DONE
QUIT
+34 QUIT
+35 ;
PROCESS ; entry point for queued report
+1 SET ZTREQ="@"
+2 SET ECXERR=0
DO EN^ECXAPHP2
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 DO HEADER
if QFLG
QUIT
+6 SET COUNT=0
SET FKEY=""
FOR
SET FKEY=$ORDER(^TMP($JOB,FKEY))
if FKEY=""!QFLG
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 SET COUNT=COUNT+1
+13 IF $Y+3>IOSL
DO HEADER
if QFLG
QUIT
+14 WRITE !,$PIECE(REC,U),?8,$PIECE(REC,U,2),?20,$PIECE(REC,U,3),?29,$EXTRACT($PIECE(REC,U,4),1,40)
+15 WRITE ?71,$PIECE(REC,U,5),?89,$$RJ^XLFSTR($PIECE(REC,U,6),9)_" "_$EXTRACT($PIECE(REC,U,7),1,7)
+16 IF ECXOPT=1
Begin DoDot:6
+17 WRITE ?108,$$RJ^XLFSTR($PIECE(REC,U,8),12),?125,$$RJ^XLFSTR($PIECE(REC,U,9),3)
End DoDot:6
+18 IF ECXOPT'=1
Begin DoDot:6
+19 WRITE ?116,$$RJ^XLFSTR($PIECE(REC,U,8),14)
End DoDot:6
+20 IF ECXOPT=3&($GET(ECXISIG))
Begin DoDot:6
+21 ;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
+22 if QFLG
QUIT
+23 IF COUNT=0
WRITE !!,?8,"No unusual volumes 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 ;tjl 166 Changed report title
WRITE !,ECXTL_" Pre-Extract Unusual Volume Report - Previous FY logic",?124,"Page: "_PG
+8 WRITE !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN
+9 WRITE !,"End Date: ",ECEND,?97,"Threshold Value = ",ECTHLD
+10 WRITE !!,"Name",?11,"SSN",?21,"Day",?29,"Generic Name",?71,"Feeder Key"
+11 IF ECXOPT=1
Begin DoDot:1
+12 WRITE ?95,"Quantity",?109,"Total Cost",?120,"Days Supply"
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 IF ECXOPT=2
WRITE ?93,"Total Doses",?121,"Total Cost",!,?95,"Per Day"
+15 IF ECXOPT'=2
WRITE ?96,"Quantity",?121,"Total Cost"
End DoDot:1
+16 WRITE !,LN,!
+17 QUIT
+18 ;
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
