93 lines
3.5 KiB
Mathematica
93 lines
3.5 KiB
Mathematica
ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ; 6/13/05 3:31pm
|
|
;;3.0;DSS EXTRACTS;**40,68,84**;Dec 22, 1997
|
|
;
|
|
EN ; entry point
|
|
N ECD,LINE,ECDRG,ECQTY,ECPRC
|
|
K ^TMP($J)
|
|
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
|
|
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 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="" D PRE2
|
|
Q
|
|
;
|
|
PRE2 ; get Prescription data
|
|
S ECDATA=$G(^PSRX(ECRX,0))
|
|
S ECDRG=+$P(ECDATA,U,6)
|
|
I ECRFL D
|
|
.S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0))
|
|
.S ECQTY=+$P(ECDATA1,U,4),ECPRC=+$P(ECDATA1,U,11)
|
|
I 'ECRFL S ECQTY=+$P(ECDATA,U,7),ECPRC=+$P(ECDATA,U,17)
|
|
D TEST
|
|
Q
|
|
;
|
|
IVP ; entry point for IVP data
|
|
N ON,DFN,DA,SA
|
|
F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECXERR Q:ECD>ECED F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN Q:ECXERR F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^("S") D
|
|
.F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA I $D(^ECX(728.113,DA,0)) S EC=^(0) D
|
|
..S ECDRG=$P(EC,U,4)
|
|
..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"")
|
|
..I SA'="" D
|
|
...I '$D(^TMP($J,SA,ECDRG)) S ^(ECDRG)=0,$P(^(ECDRG),U,2)=$P(EC,U,12)
|
|
...S $P(^TMP($J,SA,ECDRG),U)=$P(^TMP($J,SA,ECDRG),U)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
|
|
.;looped thru all DAs for this order - now put it together
|
|
.F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" D
|
|
..S ECQTY=$P(^TMP($J,SA,ECDRG),U),ECPRC=$P(^(ECDRG),U,2)
|
|
..D TEST
|
|
K ^TMP($J,"A"),^TMP($J,"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)
|
|
..S ECDRG=$P(DATA,U,4),ECQTY=$P(DATA,U,5),ECCOST=$P(DATA,U,8)
|
|
..S ECPRC=ECCOST/ECQTY
|
|
..D TEST
|
|
Q
|
|
;
|
|
TEST ; retrieve NDC and PSNDF VA Product Code Entry and test for missing NDC or VA Prod Code
|
|
N ECTYPE,ECNDC,ECZERO,K,ECPROD,ECFCHAR,ECSTOCK,ECXPHA
|
|
S ECTYPE=0,ECXPHA=""
|
|
; call pharmacy drug file (#50) api via ecxutl5
|
|
S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
|
|
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),ECNDC=$TR(ECNDC,"*",0)
|
|
S ECZERO=1,ECSTOCK=0 F K=1:1:$L(ECNDC) D Q:'ECZERO!ECSTOCK
|
|
.S ECFCHAR=$E(ECNDC,K)
|
|
.I ECFCHAR="S" S ECSTOCK=1 Q
|
|
.I ECFCHAR'=0 S ECZERO=0 Q
|
|
I ECZERO!ECSTOCK!(ECNDC["N/A") S ECTYPE=2
|
|
S ECPROD=$P(ECXPHA,U,6),ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
|
|
I ECTYPE,'ECPROD S ECTYPE=3
|
|
I 'ECTYPE,'ECPROD S ECTYPE=1
|
|
I ECTYPE D FILE
|
|
Q
|
|
;
|
|
FILE ; file record
|
|
N ECFKEY,ECGNAME,STATS,ECCOUNT,QTY,COST,ECCOST
|
|
; create new record if none exists for this drug
|
|
I '$D(^TMP($J,ECDRG)) D
|
|
.S ECFKEY=ECPROD_ECNDC
|
|
.S ECGNAME=$P($G(^PSDRUG(ECDRG,0)),U)
|
|
.S ^TMP($J,ECDRG)=ECGNAME_U_ECFKEY_U_ECPRC_U_ECTYPE
|
|
.S ^TMP($J,ECDRG,0)="0^0^0"
|
|
; add stats to record
|
|
S STATS=^TMP($J,ECDRG,0)
|
|
S ECCOUNT=$P(STATS,U),QTY=$P(STATS,U,2),COST=$P(STATS,U,3)
|
|
S ECCOUNT=ECCOUNT+1
|
|
S ECCOST=ECQTY*ECPRC
|
|
S ECQTY=ECQTY+QTY,ECCOST=ECCOST+COST
|
|
S ^TMP($J,ECDRG,0)=ECCOUNT_U_ECQTY_U_ECCOST
|
|
Q
|
|
;
|
|
EXIT S ECXERR=1 Q
|