ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ;4/9/19 15:47
;;3.0;DSS EXTRACTS;**40,49,84,104,105,113,136,143,144,174,178,184,187,190**;Dec 22, 1997;Build 36
;
; Reference to EXTRACT^PSO52EX in ICR #4902
; Reference to ^TMP($J supported by SACC 2.3.2.5.1
;
EN ; entry point
N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS,ECXCOUNT
I '$G(ECXPORT) K ^TMP($J) ;144
S (COUNT,ECDS,ECXCOUNT)=0,ECUNIT=""
S ECD=ECSD1,ECED=ECED+.3
S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",ECXOPT=4:"BCM",1:"EXIT") ;144
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)
S ECDAY=ECD ;144
S ECDFN=$P(^TMP($J,"ECXDSS",IEN,2),U) ;144
S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U) ;144
S ECCOST=ECQTY*ECPRC ;144
S ECORD=^TMP($J,"ECXDSS",IEN,.01)
;Is cost/volume greater than threshold?
I $S($G(ECXCOST):ECCOST,1:ECQTY)>ECTHLD D FILE ;144
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:"")
..I SA="" Q ;187
..; 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:-1,1:-1) ;187 if transaction type is "canceled" subtract 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
..S ECUNIT=$P(^TMP($J,SA,ECDRG),U) ;144
..S ECDAY=$P(^(ECDRG),U,2) ;144
..S ECDFN=$P(^(ECDRG),U,3) ;144
..; New Cost calculation ** 136,144
..; Removed avg cost search from 136 use existing avgcost and quantity vs count ** 143,144
..S ECCOST=$P(^(ECDRG),U,4)*ECQTY ;144
..;144 Check volume versus threshold
..I '$G(ECXCOST) I ECQTY>ECTHLD!(ECQTY<-ECTHLD) D FILE ;144
..;144 Check cost versus threshold
..I $G(ECXCOST) I ECCOST>ECTHLD D FILE ;144
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)
..S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD,ECORD=$P(DATA,U,10) ;136,144
..;144 Check volume or cost against threshold
..I $S($G(ECXCOST):ECCOST,1:ECQTY)>ECTHLD D FILE ;144
Q
;
BCM ;Section added in patch 144
N PIEN,IDAT,RIEN,ECXDFN,ECXNOD,ECXORN,ACTDT,ECXASTA,CCDORD,CCDGVN,CCUNIT,CCTYPE,DRG,ECXDRGC,UNITCOST,CCIEN,ECXIVSC,ECXIVAC,ECORD
S PIEN=0
I $G(ECSD)="" S ECSD=DT
; loop thru and get each new patient, reset the start date to ECSD
F S PIEN=$O(^PSB(53.79,"AADT",PIEN)) Q:('PIEN) Q:ECXERR S IDAT=ECSD D
.F S IDAT=$O(^PSB(53.79,"AADT",PIEN,IDAT)) Q:'IDAT!(IDAT>ECED) Q:ECXERR S RIEN="" D
..F S RIEN=$O(^PSB(53.79,"AADT",PIEN,IDAT,RIEN)) Q:'RIEN D
...S ECXNOD=^PSB(53.79,RIEN,0) Q:'ECXNOD S ECXDFN=$P($G(ECXNOD),U)
...S ECXORN=$$GET1^DIQ(53.79,RIEN,.11)
...I ECXORN["U" Q:$$CHKUD^ECXBCM(ECXDFN,ECSD,ECED) Q:ECXBCM="I"
...I ECXORN["V" Q:$$CHKIV^ECXBCM(ECXDFN,ECSD,ECED) Q:ECXBCM="N"
...S ACTDT=$$GET1^DIQ(53.79,RIEN,.06,"I") Q:ACTDT'=IDAT
...S ECXASTA=$$GET1^DIQ(53.79,RIEN,.09,"I")
...I "^G^S^C^"'[("^"_ECXASTA_"^") Q ;process 'G'iven,'S'topped,'C'ompleted
...D CCODE(RIEN)
Q
;
CCODE(RIEN) ; 144 get component information added in patch 144
; input - IEN of the BCMA MEDICATION LOG File
;
; output - CCIEN: pointer to a variable pointer field to file #50, #52.6, or #52.7
; CCDORD: .02 field of file #50, #52.6, or #52.7
; CCDGVN: .03 FIELD of file #50, #52.6, or #52.7
; CCUNIT: .04 field of file #50, #52.6, or #52.7
; CCTYPE: derived field, "D", "A", or "S"
;
N J,DATA,I
S (CCIEN,CCDORD,CCDGVN,CCUNIT,CCTYPE)=""
F I=.5,.6,.7 D Q:ECXERR
.I '$O(^PSB(53.79,RIEN,I,0)) Q
.S J=0 F S J=$O(^PSB(53.79,RIEN,I,J)) Q:'J Q:ECXERR D
..S (UNITCOST,ECXDRGC,ECXIVSC,ECXIVAC)=0
..S (ECDSPU,ECPPOU,ECDUPOU)=0 ;184
..S DATA=^PSB(53.79,RIEN,I,J,0)
..S CCIEN=$P(DATA,U),CCDORD=$P(DATA,U,2),CCDGVN=$S($P(DATA,U,3)?1.N1"E"1.N.E:1,+($P(DATA,U,3))>0:+($P(DATA,U,3)),1:1) ;174 Added check for exponential numbers
..S CCUNIT=$S($P(DATA,U,4)?1.N1"E"1.N.E:1,+($P(DATA,U,4))>0:+($P(DATA,U,4)),1:1) ;174 Added check for exponential numbers
..I I=.5 D
...S DRG=CCIEN,UNITCOST=$$GET1^DIQ(50,DRG,16,"I")
...;S ECXDRGC=(CCDGVN*CCUNIT)*UNITCOST
...S ECXDRGC=(CCDGVN*UNITCOST) ;184 Don't include Unit of Administration in Drug Cost.
..I I=.6 D
...S DRG=$$GET1^DIQ(52.6,CCIEN,1,"I"),UNITCOST=$$GET1^DIQ(52.6,CCIEN,7,"I")
...S ECXIVAC=CCDGVN*UNITCOST
..I I=.7 D
...S DRG=$$GET1^DIQ(52.7,CCIEN,1,"I"),UNITCOST=$$GET1^DIQ(52.7,CCIEN,7,"I")
...S ECXIVSC=CCDGVN*UNITCOST
..S CCTYPE=$S(I=.5:"D",I=.6:"A",I=.7:"S",1:"")
..S CCIEN=$S(I=.5:CCIEN_";PSDRUG(",I=.6:CCIEN_";PS(52.6,",I=.7:CCIEN_";PS(52.7,",1:"")
..S ECDAY=IDAT
..S ECDFN=ECXDFN
..S ECDRG=DRG
..S ECQTY=CCDGVN
..S ECCOST=$S(ECXDRGC:ECXDRGC,ECXIVSC:ECXIVSC,ECXIVAC:ECXIVAC,1:0)
..S ECORD=+ECXORN
..;S ECPPDU=UNITCOST ;184,187
..I $S($G(ECXCOST):ECCOST,1:CCDGVN)>ECTHLD D FILE
Q
;
FILE ; put records in temp file to print later
N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA,J ;144
N ECDSPU,ECPPOU,ECDUPOU ;184
N SIG ;178
S SIG="" ;178
S (ECDSPU,ECPPOU,ECDUPOU)="" ;184
; 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
S ECPPDU=$P(ECXPHA,U,7) ;187 - Price per Dispense Unit
;I ECXOPT'=2&'(ECXOPT=4&($G(ECXBCM)="I")) S ECUNIT=$P(ECXPHA,U,8)
I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8) ;184,187,190
;S ECUNIT=$P(ECXPHA,U,8) ;187 - Dispense Unit
I ECXOPT=4 S ECPPOU=$P(ECXPHA,U,9),ECDUPOU=$P(ECXPHA,U,10) ;184 Added Price Per Order Unit, Dispense Unit Per Order Unit
; 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(ECXISIG) S $P(^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN),U,10)=$$SIG^ECXAPHA(ECORD,ECDFN) ;136,144 Get SIG data if UDP or BCM Non-IV report
I $G(ECXISIG) S SIG=$S(ECXOPT=1:$$SIGPRE^ECXAPHA(ECORD),ECXOPT=2:$$SIGIVP^ECXAPHA(ON,ECDFN),ECXOPT=3:$$SIG^ECXAPHA(ECORD,ECDFN),$G(ECXBCM)="N":$$SIG^ECXAPHA(ECORD,ECDFN),1:$$SIGIVP^ECXAPHA(ECORD,ECDFN)) ;178
; 184 - Begin
;I $G(ECXISIG) S $P(^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN),U,10)=SIG ;178
S $P(^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN),U,10)=SIG
;184 - End
S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)=^(ECSSN)_U_ECPPDU ;187
I (ECXOPT=4) D ;184
.;S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)=^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)_U_CCDORD_U_ECPPDU_U_ECUNIT_U_ECPPOU_U_ECDUPOU
.S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)=^(ECSSN)_U_CCDORD_U_ECPPOU_U_ECDUPOU ;187
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[HECXAPHA2 9396 printed Dec 13, 2024@01:52:06 Page 2
ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ;4/9/19 15:47
+1 ;;3.0;DSS EXTRACTS;**40,49,84,104,105,113,136,143,144,174,178,184,187,190**;Dec 22, 1997;Build 36
+2 ;
+3 ; Reference to EXTRACT^PSO52EX in ICR #4902
+4 ; Reference to ^TMP($J supported by SACC 2.3.2.5.1
+5 ;
EN ; entry point
+1 NEW COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS,ECXCOUNT
+2 ;144
IF '$GET(ECXPORT)
KILL ^TMP($JOB)
+3 SET (COUNT,ECDS,ECXCOUNT)=0
SET ECUNIT=""
+4 SET ECD=ECSD1
SET ECED=ECED+.3
+5 ;144
SET LINE=$SELECT(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",ECXOPT=4:"BCM",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 ;144
SET ECDAY=ECD
+14 ;144
SET ECDFN=$PIECE(^TMP($JOB,"ECXDSS",IEN,2),U)
+15 ;144
SET ECDRG=+$PIECE(^TMP($JOB,"ECXDSS",IEN,6),U)
+16 ;144
SET ECCOST=ECQTY*ECPRC
+17 SET ECORD=^TMP($JOB,"ECXDSS",IEN,.01)
+18 ;Is cost/volume greater than threshold?
+19 ;144
IF $SELECT($GET(ECXCOST):ECCOST,1:ECQTY)>ECTHLD
DO FILE
+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 ;187
IF SA=""
QUIT
+7 ; set up new record for first DA for this drug
+8 IF '$DATA(^TMP($JOB,SA,ECDRG))
Begin DoDot:3
+9 SET ECQTY=+$SELECT(SA="A":+$PIECE(EC,U,7),SA="S":+$PIECE(EC,U,9),1:0)
+10 SET ECUNIT=$SELECT(SA="A":$PIECE(EC,U,8),SA="S":"ML",1:"")
+11 SET ECCOST=$PIECE(EC,U,12)
SET ECDFN=DFN
+12 SET ^TMP($JOB,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY
+13 SET ^(ECDRG,1)=0
End DoDot:3
+14 ; add to qty (0,1, or -1) to total
+15 ;187 if transaction type is "canceled" subtract 1
SET ^TMP($JOB,SA,ECDRG,1)=^TMP($JOB,SA,ECDRG,1)+$SELECT($PIECE(EC,U,6)=1:1,$PIECE(EC,U,6)=4:-1,1:-1)
End DoDot:2
+16 ; looped thru all DAs for this order - now check for unusual volumes
+17 FOR SA="S","A"
SET ECDRG=""
FOR
SET ECDRG=$ORDER(^TMP($JOB,SA,ECDRG))
if ECDRG=""
QUIT
if ECXERR
QUIT
Begin DoDot:2
+18 SET ECQTY=$PIECE(^TMP($JOB,SA,ECDRG),U,5)
SET ECCOUNT=^(ECDRG,1)
+19 SET ECQTY=ECQTY*ECCOUNT
+20 ;144
SET ECUNIT=$PIECE(^TMP($JOB,SA,ECDRG),U)
+21 ;144
SET ECDAY=$PIECE(^(ECDRG),U,2)
+22 ;144
SET ECDFN=$PIECE(^(ECDRG),U,3)
+23 ; New Cost calculation ** 136,144
+24 ; Removed avg cost search from 136 use existing avgcost and quantity vs count ** 143,144
+25 ;144
SET ECCOST=$PIECE(^(ECDRG),U,4)*ECQTY
+26 ;144 Check volume versus threshold
+27 ;144
IF '$GET(ECXCOST)
IF ECQTY>ECTHLD!(ECQTY<-ECTHLD)
DO FILE
+28 ;144 Check cost versus threshold
+29 ;144
IF $GET(ECXCOST)
IF ECCOST>ECTHLD
DO FILE
End DoDot:2
End DoDot:1
if ECXERR
QUIT
+30 KILL ^TMP($JOB,"A"),^("S")
+31 QUIT
+32 ;
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 ;136,144
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)
+6 ;144 Check volume or cost against threshold
+7 ;144
IF $SELECT($GET(ECXCOST):ECCOST,1:ECQTY)>ECTHLD
DO FILE
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
BCM ;Section added in patch 144
+1 NEW PIEN,IDAT,RIEN,ECXDFN,ECXNOD,ECXORN,ACTDT,ECXASTA,CCDORD,CCDGVN,CCUNIT,CCTYPE,DRG,ECXDRGC,UNITCOST,CCIEN,ECXIVSC,ECXIVAC,ECORD
+2 SET PIEN=0
+3 IF $GET(ECSD)=""
SET ECSD=DT
+4 ; loop thru and get each new patient, reset the start date to ECSD
+5 FOR
SET PIEN=$ORDER(^PSB(53.79,"AADT",PIEN))
if ('PIEN)
QUIT
if ECXERR
QUIT
SET IDAT=ECSD
Begin DoDot:1
+6 FOR
SET IDAT=$ORDER(^PSB(53.79,"AADT",PIEN,IDAT))
if 'IDAT!(IDAT>ECED)
QUIT
if ECXERR
QUIT
SET RIEN=""
Begin DoDot:2
+7 FOR
SET RIEN=$ORDER(^PSB(53.79,"AADT",PIEN,IDAT,RIEN))
if 'RIEN
QUIT
Begin DoDot:3
+8 SET ECXNOD=^PSB(53.79,RIEN,0)
if 'ECXNOD
QUIT
SET ECXDFN=$PIECE($GET(ECXNOD),U)
+9 SET ECXORN=$$GET1^DIQ(53.79,RIEN,.11)
+10 IF ECXORN["U"
if $$CHKUD^ECXBCM(ECXDFN,ECSD,ECED)
QUIT
if ECXBCM="I"
QUIT
+11 IF ECXORN["V"
if $$CHKIV^ECXBCM(ECXDFN,ECSD,ECED)
QUIT
if ECXBCM="N"
QUIT
+12 SET ACTDT=$$GET1^DIQ(53.79,RIEN,.06,"I")
if ACTDT'=IDAT
QUIT
+13 SET ECXASTA=$$GET1^DIQ(53.79,RIEN,.09,"I")
+14 ;process 'G'iven,'S'topped,'C'ompleted
IF "^G^S^C^"'[("^"_ECXASTA_"^")
QUIT
+15 DO CCODE(RIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
CCODE(RIEN) ; 144 get component information added in patch 144
+1 ; input - IEN of the BCMA MEDICATION LOG File
+2 ;
+3 ; output - CCIEN: pointer to a variable pointer field to file #50, #52.6, or #52.7
+4 ; CCDORD: .02 field of file #50, #52.6, or #52.7
+5 ; CCDGVN: .03 FIELD of file #50, #52.6, or #52.7
+6 ; CCUNIT: .04 field of file #50, #52.6, or #52.7
+7 ; CCTYPE: derived field, "D", "A", or "S"
+8 ;
+9 NEW J,DATA,I
+10 SET (CCIEN,CCDORD,CCDGVN,CCUNIT,CCTYPE)=""
+11 FOR I=.5,.6,.7
Begin DoDot:1
+12 IF '$ORDER(^PSB(53.79,RIEN,I,0))
QUIT
+13 SET J=0
FOR
SET J=$ORDER(^PSB(53.79,RIEN,I,J))
if 'J
QUIT
if ECXERR
QUIT
Begin DoDot:2
+14 SET (UNITCOST,ECXDRGC,ECXIVSC,ECXIVAC)=0
+15 ;184
SET (ECDSPU,ECPPOU,ECDUPOU)=0
+16 SET DATA=^PSB(53.79,RIEN,I,J,0)
+17 ;174 Added check for exponential numbers
SET CCIEN=$PIECE(DATA,U)
SET CCDORD=$PIECE(DATA,U,2)
SET CCDGVN=$SELECT($PIECE(DATA,U,3)?1.N1"E"1.N.E:1,+($PIECE(DATA,U,3))>0:+($PIECE(DATA,U,3)),1:1)
+18 ;174 Added check for exponential numbers
SET CCUNIT=$SELECT($PIECE(DATA,U,4)?1.N1"E"1.N.E:1,+($PIECE(DATA,U,4))>0:+($PIECE(DATA,U,4)),1:1)
+19 IF I=.5
Begin DoDot:3
+20 SET DRG=CCIEN
SET UNITCOST=$$GET1^DIQ(50,DRG,16,"I")
+21 ;S ECXDRGC=(CCDGVN*CCUNIT)*UNITCOST
+22 ;184 Don't include Unit of Administration in Drug Cost.
SET ECXDRGC=(CCDGVN*UNITCOST)
End DoDot:3
+23 IF I=.6
Begin DoDot:3
+24 SET DRG=$$GET1^DIQ(52.6,CCIEN,1,"I")
SET UNITCOST=$$GET1^DIQ(52.6,CCIEN,7,"I")
+25 SET ECXIVAC=CCDGVN*UNITCOST
End DoDot:3
+26 IF I=.7
Begin DoDot:3
+27 SET DRG=$$GET1^DIQ(52.7,CCIEN,1,"I")
SET UNITCOST=$$GET1^DIQ(52.7,CCIEN,7,"I")
+28 SET ECXIVSC=CCDGVN*UNITCOST
End DoDot:3
+29 SET CCTYPE=$SELECT(I=.5:"D",I=.6:"A",I=.7:"S",1:"")
+30 SET CCIEN=$SELECT(I=.5:CCIEN_";PSDRUG(",I=.6:CCIEN_";PS(52.6,",I=.7:CCIEN_";PS(52.7,",1:"")
+31 SET ECDAY=IDAT
+32 SET ECDFN=ECXDFN
+33 SET ECDRG=DRG
+34 SET ECQTY=CCDGVN
+35 SET ECCOST=$SELECT(ECXDRGC:ECXDRGC,ECXIVSC:ECXIVSC,ECXIVAC:ECXIVAC,1:0)
+36 SET ECORD=+ECXORN
+37 ;S ECPPDU=UNITCOST ;184,187
+38 IF $SELECT($GET(ECXCOST):ECCOST,1:CCDGVN)>ECTHLD
DO FILE
End DoDot:2
End DoDot:1
if ECXERR
QUIT
+39 QUIT
+40 ;
FILE ; put records in temp file to print later
+1 ;144
NEW OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA,J
+2 ;184
NEW ECDSPU,ECPPOU,ECDUPOU
+3 ;178
NEW SIG
+4 ;178
SET SIG=""
+5 ;184
SET (ECDSPU,ECPPOU,ECDUPOU)=""
+6 ; get demographics
+7 SET OK=$$PAT^ECXUTL3(ECDFN,$PIECE(ECD,"."),"1;",.ECXPAT)
+8 IF 'OK
QUIT
+9 SET ECNAME=ECXPAT("NAME")
+10 SET ECSSN=ECXPAT("SSN")
+11 SET ECDAY=$EXTRACT(ECDAY,4,5)_"/"_$EXTRACT(ECDAY,6,7)
+12 ; get drug file data
+13 SET ECXPHA=""
SET ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
+14 SET ECGNAME=$PIECE(ECXPHA,U)
+15 SET ECNDC=$PIECE(ECXPHA,U,3)
+16 SET ECNDC=$$RJ^XLFSTR($PIECE(ECNDC,"-"),6,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",3),2,0)
+17 SET ECNDC=$TRANSLATE(ECNDC,"*",0)
+18 SET ECPROD=$PIECE(ECXPHA,U,6)
+19 SET ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
+20 SET ECFKEY=ECPROD_ECNDC
+21 ;187 - Price per Dispense Unit
SET ECPPDU=$PIECE(ECXPHA,U,7)
+22 ;I ECXOPT'=2&'(ECXOPT=4&($G(ECXBCM)="I")) S ECUNIT=$P(ECXPHA,U,8)
+23 ;184,187,190
IF ECXOPT'=2
SET ECUNIT=$PIECE(ECXPHA,U,8)
+24 ;S ECUNIT=$P(ECXPHA,U,8) ;187 - Dispense Unit
+25 ;184 Added Price Per Order Unit, Dispense Unit Per Order Unit
IF ECXOPT=4
SET ECPPOU=$PIECE(ECXPHA,U,9)
SET ECDUPOU=$PIECE(ECXPHA,U,10)
+26 ; file
+27 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
+28 ;I $G(ECXISIG) S $P(^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN),U,10)=$$SIG^ECXAPHA(ECORD,ECDFN) ;136,144 Get SIG data if UDP or BCM Non-IV report
+29 ;178
IF $GET(ECXISIG)
SET SIG=$SELECT(ECXOPT=1:$$SIGPRE^ECXAPHA(ECORD),ECXOPT=2:$$SIGIVP^ECXAPHA(ON,ECDFN),ECXOPT=3:$$SIG^ECXAPHA(ECORD,ECDFN),$GET(ECXBCM)="N":$$SIG^ECXAPHA(ECORD,ECDFN),1:$$SIGIVP^ECXAPHA(ECORD,ECDFN))
+30 ; 184 - Begin
+31 ;I $G(ECXISIG) S $P(^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN),U,10)=SIG ;178
+32 SET $PIECE(^TMP($JOB,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN),U,10)=SIG
+33 ;184 - End
+34 ;187
SET ^TMP($JOB,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)=^(ECSSN)_U_ECPPDU
+35 ;184
IF (ECXOPT=4)
Begin DoDot:1
+36 ;S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)=^TMP($J,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)_U_CCDORD_U_ECPPDU_U_ECUNIT_U_ECPPOU_U_ECDUPOU
+37 ;187
SET ^TMP($JOB,ECFKEY,-ECQTY,ECDAY,ECXCOUNT,ECSSN)=^(ECSSN)_U_CCDORD_U_ECPPOU_U_ECDUPOU
End DoDot:1
+38 SET COUNT=COUNT+1
+39 SET ECXCOUNT=ECXCOUNT+1
+40 ;136 Update ZTSTOP var to be spelled correctly
IF COUNT#100=0
IF $$S^ZTLOAD
SET (ZTSTOP,ECXERR)=1
+41 QUIT
+42 ;
EXIT SET ECXERR=1
QUIT
