ECXAPHP2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ;3/26/13 16:07
;;3.0;DSS EXTRACTS;**40,49,84,104,105,113,136,143,144**;Dec 22, 1997;Build 9
;
;This routine is new with patch 144 but is a copy of ECXAPHA2 before it
;was changed for the FY update. This is now the previous fiscal year
;version of the routine
EN ; entry point
N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS,ECXCOUNT
K ^TMP($J)
S (COUNT,ECDS,ECXCOUNT)=0,ECUNIT=""
S ECD=ECSD1,ECED=ECED+.3
S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT")
D @LINE
Q
;
PRE ; entry point for PRE data
N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC,IEN
K ^TMP($J,"ECXDSS")
;call pharmacy api pso52ex
D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS")
S ECREF="RF"
;order thru fills and refills; refill values 0 thru 11
; Note: refill 0 = original fill
F S ECD=$O(^TMP($J,"ECXDSS","AL",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^TMP($J,"ECXDSS","AL",ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^TMP($J,"ECXDSS","AL",ECD,IEN,ECRFL)) Q:ECRFL="" Q:ECXERR D PRE2
;
;order thru partial fills
S ECD=ECSD1,ECREF="P"
F S ECD=$O(^TMP($J,"ECXDSS","AM",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL Q:ECXERR D PRE2
K ^TMP($J,"ECXDSS")
Q
;
PRE2 ; get Prescription data
I (ECREF="RF")&(ECRFL) D
.S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1)
.S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.1)
.S ECPRC=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.2)
I (ECREF="RF")&('ECRFL) D
.S ECQTY=+^TMP($J,"ECXDSS",IEN,7)
.S ECDS=+^TMP($J,"ECXDSS",IEN,8)
.S ECPRC=+^TMP($J,"ECXDSS",IEN,17)
I ECREF="P" D
.S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04)
.S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.041)
.S ECPRC=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.042)
;check to see if quantity>threshold
I ECQTY>ECTHLD D
.S ECDAY=ECD
.S ECDFN=$P(^TMP($J,"ECXDSS",IEN,2),U)
.S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U)
.S ECCOST=ECQTY*ECPRC
.D FILE Q:ECXERR
Q
;
IVP ; entry point for IVP Data
N DFN,ON,DA,SA,ECCOUNT ;143
F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^("S") D Q:ECXERR
.F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:ECXERR I $D(^ECX(728.113,DA,0)) S EC=^(0) Q:ECXERR D
..S ECDRG=$P(EC,U,4)
..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"")
..; set up new record for first DA for this drug
..I '$D(^TMP($J,SA,ECDRG)) D
...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0)
...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"")
...S ECCOST=$P(EC,U,12),ECDFN=DFN
...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY
...S ^(ECDRG,1)=0
..; add to qty (0,1, or -1) to total
..S ^TMP($J,SA,ECDRG,1)=^TMP($J,SA,ECDRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
.; looped thru all DAs for this order - now check for unusual volumes
.F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" Q:ECXERR D
..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1)
..S ECQTY=ECQTY*ECCOUNT
..; check to see if quantity is outside of threshold range
..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D
...S ECUNIT=$P(^TMP($J,SA,ECDRG),U)
...S ECDAY=$P(^(ECDRG),U,2)
...S ECDFN=$P(^(ECDRG),U,3)
...; New Cost calculation ** 136
...; Removed avg cost search from 136 use existing avgcost and quantity vs count ** 143
...S ECCOST=$P(^(ECDRG),U,4)*ECQTY
...D FILE Q:ECXERR
K ^TMP($J,"A"),^("S")
Q
;
UDP ; entry point for UDP data
N ECXJ,ECDATA,ECORD ;136
F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D
.S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:ECXERR I $D(^ECX(728.904,ECXJ,0)) D
..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5)
..;check to see if quantity>threshold
..I ECQTY>ECTHLD D
...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD,ECORD=$P(DATA,U,10) ;136
...D FILE Q:ECXERR
Q
;
FILE ; put records in temp file to print later
N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA
; get demographics
S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT)
I 'OK Q
S ECNAME=ECXPAT("NAME")
S ECSSN=ECXPAT("SSN")
S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7)
; get drug file data
S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
S ECGNAME=$P(ECXPHA,U)
S ECNDC=$P(ECXPHA,U,3)
S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0)
S ECNDC=$TR(ECNDC,"*",0)
S ECPROD=$P(ECXPHA,U,6)
S ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
S ECFKEY=ECPROD_ECNDC
I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8)
; file
S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",4)_U_ECDS
I $G(ECXOPT)=3 S $P(^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN),U,10)=$$SIG^ECXAPHAP(ECORD,ECDFN) ;136 Get SIG data if UDP report
S COUNT=COUNT+1
S ECXCOUNT=ECXCOUNT+1
I COUNT#100=0 I $$S^ZTLOAD S (ZTSTOP,ECXERR)=1 ;136 Update ZTSTOP var to be spelled correctly
Q
;
EXIT S ECXERR=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXAPHP2 5222 printed Oct 16, 2024@17:52:57 Page 2
ECXAPHP2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ;3/26/13 16:07
+1 ;;3.0;DSS EXTRACTS;**40,49,84,104,105,113,136,143,144**;Dec 22, 1997;Build 9
+2 ;
+3 ;This routine is new with patch 144 but is a copy of ECXAPHA2 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 COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS,ECXCOUNT
+2 KILL ^TMP($JOB)
+3 SET (COUNT,ECDS,ECXCOUNT)=0
SET ECUNIT=""
+4 SET ECD=ECSD1
SET ECED=ECED+.3
+5 SET LINE=$SELECT(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT")
+6 DO @LINE
+7 QUIT
+8 ;
PRE ; entry point for PRE data
+1 NEW ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC,IEN
+2 KILL ^TMP($JOB,"ECXDSS")
+3 ;call pharmacy api pso52ex
+4 DO EXTRACT^PSO52EX(ECD,ECED,"ECXDSS")
+5 SET ECREF="RF"
+6 ;order thru fills and refills; refill values 0 thru 11
+7 ; Note: refill 0 = original fill
+8 FOR
SET ECD=$ORDER(^TMP($JOB,"ECXDSS","AL",ECD))
SET IEN=0
if 'ECD
QUIT
if ECD>ECED
QUIT
if ECXERR
QUIT
FOR
SET IEN=$ORDER(^TMP($JOB,"ECXDSS","AL",ECD,IEN))
SET ECRFL=""
if 'IEN
QUIT
if ECXERR
QUIT
FOR
SET ECRFL=$ORDER(^TMP($JOB,"ECXDSS","AL",ECD,IEN,ECRFL))
if ECRFL=""
QUIT
if ECXERR
QUIT
DO PRE2
+9 ;
+10 ;order thru partial fills
+11 SET ECD=ECSD1
SET ECREF="P"
+12 FOR
SET ECD=$ORDER(^TMP($JOB,"ECXDSS","AM",ECD))
SET IEN=0
if 'ECD
QUIT
if ECD>ECED
QUIT
if ECXERR
QUIT
FOR
SET IEN=$ORDER(^(ECD,IEN))
SET ECRFL=""
if 'IEN
QUIT
if ECXERR
QUIT
FOR
SET ECRFL=$ORDER(^(IEN,ECRFL))
if 'ECRFL
QUIT
if ECXERR
QUIT
DO PRE2
+13 KILL ^TMP($JOB,"ECXDSS")
+14 QUIT
+15 ;
PRE2 ; get Prescription data
+1 IF (ECREF="RF")&(ECRFL)
Begin DoDot:1
+2 SET ECQTY=+^TMP($JOB,"ECXDSS",IEN,ECREF,ECRFL,1)
+3 SET ECDS=+^TMP($JOB,"ECXDSS",IEN,ECREF,ECRFL,1.1)
+4 SET ECPRC=^TMP($JOB,"ECXDSS",IEN,ECREF,ECRFL,1.2)
End DoDot:1
+5 IF (ECREF="RF")&('ECRFL)
Begin DoDot:1
+6 SET ECQTY=+^TMP($JOB,"ECXDSS",IEN,7)
+7 SET ECDS=+^TMP($JOB,"ECXDSS",IEN,8)
+8 SET ECPRC=+^TMP($JOB,"ECXDSS",IEN,17)
End DoDot:1
+9 IF ECREF="P"
Begin DoDot:1
+10 SET ECQTY=+^TMP($JOB,"ECXDSS",IEN,ECREF,ECRFL,.04)
+11 SET ECDS=+^TMP($JOB,"ECXDSS",IEN,ECREF,ECRFL,.041)
+12 SET ECPRC=+^TMP($JOB,"ECXDSS",IEN,ECREF,ECRFL,.042)
End DoDot:1
+13 ;check to see if quantity>threshold
+14 IF ECQTY>ECTHLD
Begin DoDot:1
+15 SET ECDAY=ECD
+16 SET ECDFN=$PIECE(^TMP($JOB,"ECXDSS",IEN,2),U)
+17 SET ECDRG=+$PIECE(^TMP($JOB,"ECXDSS",IEN,6),U)
+18 SET ECCOST=ECQTY*ECPRC
+19 DO FILE
if ECXERR
QUIT
End DoDot:1
+20 QUIT
+21 ;
IVP ; entry point for IVP Data
+1 ;143
NEW DFN,ON,DA,SA,ECCOUNT
+2 FOR
SET ECD=$ORDER(^ECX(728.113,"A",ECD))
SET DFN=0
if 'ECD
QUIT
if ECD>ECED
QUIT
if ECXERR
QUIT
FOR
SET DFN=$ORDER(^ECX(728.113,"A",ECD,DFN))
SET ON=0
if 'DFN
QUIT
FOR
SET ON=$ORDER(^ECX(728.113,"A",ECD,DFN,ON))
SET DA=0
if 'ON
QUIT
KILL ^TMP($JOB,"A"),^("S")
Begin DoDot:1
+3 FOR
SET DA=$ORDER(^ECX(728.113,"A",ECD,DFN,ON,DA))
if 'DA
QUIT
if ECXERR
QUIT
IF $DATA(^ECX(728.113,DA,0))
SET EC=^(0)
if ECXERR
QUIT
Begin DoDot:2
+4 SET ECDRG=$PIECE(EC,U,4)
+5 SET SA=$SELECT($PIECE(EC,U,8)]"":"A",$PIECE(EC,U,9):"S",1:"")
+6 ; set up new record for first DA for this drug
+7 IF '$DATA(^TMP($JOB,SA,ECDRG))
Begin DoDot:3
+8 SET ECQTY=+$SELECT(SA="A":+$PIECE(EC,U,7),SA="S":+$PIECE(EC,U,9),1:0)
+9 SET ECUNIT=$SELECT(SA="A":$PIECE(EC,U,8),SA="S":"ML",1:"")
+10 SET ECCOST=$PIECE(EC,U,12)
SET ECDFN=DFN
+11 SET ^TMP($JOB,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY
+12 SET ^(ECDRG,1)=0
End DoDot:3
+13 ; add to qty (0,1, or -1) to total
+14 SET ^TMP($JOB,SA,ECDRG,1)=^TMP($JOB,SA,ECDRG,1)+$SELECT($PIECE(EC,U,6)=1:1,$PIECE(EC,U,6)=4:0,1:-1)
End DoDot:2
+15 ; looped thru all DAs for this order - now check for unusual volumes
+16 FOR SA="S","A"
SET ECDRG=""
FOR
SET ECDRG=$ORDER(^TMP($JOB,SA,ECDRG))
if ECDRG=""
QUIT
if ECXERR
QUIT
Begin DoDot:2
+17 SET ECQTY=$PIECE(^TMP($JOB,SA,ECDRG),U,5)
SET ECCOUNT=^(ECDRG,1)
+18 SET ECQTY=ECQTY*ECCOUNT
+19 ; check to see if quantity is outside of threshold range
+20 IF (ECQTY>ECTHLD)!(ECQTY<-ECTHLD)
Begin DoDot:3
+21 SET ECUNIT=$PIECE(^TMP($JOB,SA,ECDRG),U)
+22 SET ECDAY=$PIECE(^(ECDRG),U,2)
+23 SET ECDFN=$PIECE(^(ECDRG),U,3)
+24 ; New Cost calculation ** 136
+25 ; Removed avg cost search from 136 use existing avgcost and quantity vs count ** 143
+26 SET ECCOST=$PIECE(^(ECDRG),U,4)*ECQTY
+27 DO FILE
if ECXERR
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
if ECXERR
QUIT
+28 KILL ^TMP($JOB,"A"),^("S")
+29 QUIT
+30 ;
UDP ; entry point for UDP data
+1 ;136
NEW ECXJ,ECDATA,ECORD
+2 FOR
SET ECD=$ORDER(^ECX(728.904,"A",ECD))
if 'ECD
QUIT
if ECD>ECED
QUIT
if ECXERR
QUIT
Begin DoDot:1
+3 SET ECXJ=0
FOR
SET ECXJ=$ORDER(^ECX(728.904,"A",ECD,ECXJ))
if 'ECXJ
QUIT
if ECXERR
QUIT
IF $DATA(^ECX(728.904,ECXJ,0))
Begin DoDot:2
+4 SET DATA=^ECX(728.904,ECXJ,0)
SET ECQTY=$PIECE(DATA,U,5)
+5 ;check to see if quantity>threshold
+6 IF ECQTY>ECTHLD
Begin DoDot:3
+7 ;136
SET ECDFN=$PIECE(DATA,U,2)
SET ECDRG=$PIECE(DATA,U,4)
SET ECCOST=$PIECE(DATA,U,8)
SET ECDAY=ECD
SET ECORD=$PIECE(DATA,U,10)
+8 DO FILE
if ECXERR
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
FILE ; put records in temp file to print later
+1 NEW OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA
+2 ; get demographics
+3 SET OK=$$PAT^ECXUTL3(ECDFN,$PIECE(ECD,"."),"1;",.ECXPAT)
+4 IF 'OK
QUIT
+5 SET ECNAME=ECXPAT("NAME")
+6 SET ECSSN=ECXPAT("SSN")
+7 SET ECDAY=$EXTRACT(ECDAY,4,5)_"/"_$EXTRACT(ECDAY,6,7)
+8 ; get drug file data
+9 SET ECXPHA=""
SET ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
+10 SET ECGNAME=$PIECE(ECXPHA,U)
+11 SET ECNDC=$PIECE(ECXPHA,U,3)
+12 SET ECNDC=$$RJ^XLFSTR($PIECE(ECNDC,"-"),6,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",3),2,0)
+13 SET ECNDC=$TRANSLATE(ECNDC,"*",0)
+14 SET ECPROD=$PIECE(ECXPHA,U,6)
+15 SET ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
+16 SET ECFKEY=ECPROD_ECNDC
+17 IF ECXOPT'=2
SET ECUNIT=$PIECE(ECXPHA,U,8)
+18 ; file
+19 SET ^TMP($JOB,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",4)_U_ECDS
+20 ;136 Get SIG data if UDP report
IF $GET(ECXOPT)=3
SET $PIECE(^TMP($JOB,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN),U,10)=$$SIG^ECXAPHAP(ECORD,ECDFN)
+21 SET COUNT=COUNT+1
+22 SET ECXCOUNT=ECXCOUNT+1
+23 ;136 Update ZTSTOP var to be spelled correctly
IF COUNT#100=0
IF $$S^ZTLOAD
SET (ZTSTOP,ECXERR)=1
+24 QUIT
+25 ;
EXIT SET ECXERR=1
QUIT
