107 lines
4.0 KiB
Mathematica
107 lines
4.0 KiB
Mathematica
ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 2/06/07 10:36am
|
|
;;3.0;DSS EXTRACTS;**40,49,84,104**;Dec 22, 1997;Build 8
|
|
;
|
|
EN ; entry point
|
|
N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS
|
|
K ^TMP($J)
|
|
S (COUNT,ECDS)=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
|
|
; order through fills, refills and partial refills
|
|
N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC
|
|
S ECREF=1
|
|
F S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX Q:ECXERR F S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL="" Q:ECXERR D PRE2
|
|
S ECD=ECSD1,ECREF="P"
|
|
F S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL="" Q:ECXERR D PRE2
|
|
Q
|
|
;
|
|
PRE2 ; get Prescription data
|
|
S ECDATA=$G(^PSRX(ECRX,0))
|
|
I ECRFL D
|
|
.S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0))
|
|
.S ECQTY=+$P(ECDATA1,U,4)
|
|
.S ECDS=+$P(ECDATA1,U,10)
|
|
.S ECPRC=+$P(ECDATA1,U,11)
|
|
I 'ECRFL D
|
|
.S ECQTY=+$P(ECDATA,U,7)
|
|
.S ECDS=+$P(ECDATA,U,8)
|
|
.S ECPRC=+$P(ECDATA,U,17)
|
|
;check to see if quantity>threshold
|
|
I ECQTY>ECTHLD D
|
|
.S ECDAY=ECD
|
|
.S ECDFN=$P(ECDATA,U,2)
|
|
.S ECDRG=+$P(ECDATA,U,6)
|
|
.S ECCOST=ECQTY*ECPRC
|
|
.D FILE Q:ECXERR
|
|
Q
|
|
;
|
|
IVP ; entry point for IVP Data
|
|
N DFN,ON,DA,SA,ECCOUNT
|
|
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)
|
|
...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT
|
|
...D FILE Q:ECXERR
|
|
K ^TMP($J,"A"),^("S")
|
|
Q
|
|
;
|
|
UDP ; entry point for UDP data
|
|
N ECXJ,ECDATA
|
|
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
|
|
...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,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",2)_U_ECDS
|
|
S COUNT=COUNT+1
|
|
I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
|
|
Q
|
|
;
|
|
EXIT S ECXERR=1 Q
|