ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ;5/9/19 17:13
;;3.0;DSS EXTRACTS;**40,68,84,105,111,144,174,187**;Dec 22, 1997;Build 163
;
; Reference to ^PSDRUG( in ICR #4846
; Reference to EXTRACT^PSO52EX in ICR #4902
; Reference to $$RJ^XLFSTR in ICR #10104
; Reference to ^TMP($J in SACC 2.3.2.5.1
;
EN ; entry point
N ECD,LINE,ECDRG,ECQTY,ECPRC
I '$G(ECXPORT) K ^TMP($J) ;144 Already killed if exporting
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
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(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(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
S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U)
I ECRFL>0&(ECREF="RF") D
.S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1),ECPRC=^(1.2)
I ECRFL>0&(ECREF="P") D
.S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04),ECPRC=^(.042)
I 'ECRFL S ECQTY=^TMP($J,"ECXDSS",IEN,7),ECPRC=^(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:-1,1:-1) ;187 Deduct 1 if transaction type is cancel.
.;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,LOCAL ;174
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,LOCAL=0 F K=1:1:$L(ECNDC) D Q:'ECZERO!ECSTOCK!LOCAL ;174
.S ECFCHAR=$E(ECNDC,K)
.I $E(ECNDC,1)="L" S LOCAL=1 Q ;174 If NDC is blank and marked with LCL or LCD, stop processing
.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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXDRUG2 4357 printed Oct 16, 2024@17:53:16 Page 2
ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ;5/9/19 17:13
+1 ;;3.0;DSS EXTRACTS;**40,68,84,105,111,144,174,187**;Dec 22, 1997;Build 163
+2 ;
+3 ; Reference to ^PSDRUG( in ICR #4846
+4 ; Reference to EXTRACT^PSO52EX in ICR #4902
+5 ; Reference to $$RJ^XLFSTR in ICR #10104
+6 ; Reference to ^TMP($J in SACC 2.3.2.5.1
+7 ;
EN ; entry point
+1 NEW ECD,LINE,ECDRG,ECQTY,ECPRC
+2 ;144 Already killed if exporting
IF '$GET(ECXPORT)
KILL ^TMP($JOB)
+3 SET ECD=ECSD1
SET ECED=ECED+.3
+4 SET LINE=$SELECT(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT")
+5 DO @LINE
+6 QUIT
+7 ;
PRE ; entry point for PRE data
+1 ; order through fills, refills and partial refills
+2 NEW ECRFL,ECRX,ECREF,ECDATA,ECDATA1
+3 KILL ^TMP($JOB,"ECXDSS")
+4 ;call pharmacy api pso52ex
+5 DO EXTRACT^PSO52EX(ECD,ECED,"ECXDSS")
+6 SET ECREF="RF"
+7 ;order thru fills and refills; refill values 0 thru 11
+8 ; Note: refill 0 = original fill
+9 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(^(ECD,IEN))
SET ECRFL=""
if 'IEN
QUIT
if ECXERR
QUIT
FOR
SET ECRFL=$ORDER(^(IEN,ECRFL))
if ECRFL']""
QUIT
if ECXERR
QUIT
DO PRE2
+10 ;
+11 ;order thru partial fills
+12 SET ECD=ECSD1
SET ECREF="P"
+13 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
+14 KILL ^TMP($JOB,"ECXDSS")
+15 QUIT
+16 ;
PRE2 ; get Prescription data
+1 SET ECDRG=+$PIECE(^TMP($JOB,"ECXDSS",IEN,6),U)
+2 IF ECRFL>0&(ECREF="RF")
Begin DoDot:1
+3 SET ECQTY=^TMP($JOB,"ECXDSS",IEN,ECREF,ECRFL,1)
SET ECPRC=^(1.2)
End DoDot:1
+4 IF ECRFL>0&(ECREF="P")
Begin DoDot:1
+5 SET ECQTY=^TMP($JOB,"ECXDSS",IEN,ECREF,ECRFL,.04)
SET ECPRC=^(.042)
End DoDot:1
+6 IF 'ECRFL
SET ECQTY=^TMP($JOB,"ECXDSS",IEN,7)
SET ECPRC=^(17)
+7 DO TEST
+8 QUIT
+9 ;
IVP ; entry point for IVP data
+1 NEW ON,DFN,DA,SA
+2 FOR
SET ECD=$ORDER(^ECX(728.113,"A",ECD))
SET DFN=0
if 'ECD
QUIT
if ECXERR
QUIT
if ECD>ECED
QUIT
FOR
SET DFN=$ORDER(^ECX(728.113,"A",ECD,DFN))
SET ON=0
if 'DFN
QUIT
if ECXERR
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 $DATA(^ECX(728.113,DA,0))
SET EC=^(0)
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 IF SA'=""
Begin DoDot:3
+7 IF '$DATA(^TMP($JOB,SA,ECDRG))
SET ^(ECDRG)=0
SET $PIECE(^(ECDRG),U,2)=$PIECE(EC,U,12)
+8 ;187 Deduct 1 if transaction type is cancel.
SET $PIECE(^TMP($JOB,SA,ECDRG),U)=$PIECE(^TMP($JOB,SA,ECDRG),U)+$SELECT($PIECE(EC,U,6)=1:1,$PIECE(EC,U,6)=4:-1,1:-1)
End DoDot:3
End DoDot:2
+9 ;looped thru all DAs for this order - now put it together
+10 FOR SA="S","A"
SET ECDRG=""
FOR
SET ECDRG=$ORDER(^TMP($JOB,SA,ECDRG))
if ECDRG=""
QUIT
Begin DoDot:2
+11 SET ECQTY=$PIECE(^TMP($JOB,SA,ECDRG),U)
SET ECPRC=$PIECE(^(ECDRG),U,2)
+12 DO TEST
End DoDot:2
End DoDot:1
+13 KILL ^TMP($JOB,"A"),^TMP($JOB,"S")
+14 QUIT
+15 ;
UDP ; entry point for UDP data
+1 NEW ECXJ,ECDATA
+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)
+5 SET ECDRG=$PIECE(DATA,U,4)
SET ECQTY=$PIECE(DATA,U,5)
SET ECCOST=$PIECE(DATA,U,8)
+6 SET ECPRC=ECCOST/ECQTY
+7 DO TEST
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
TEST ; retrieve NDC and PSNDF VA Product Code Entry and test for missing NDC or VA Prod Code
+1 ;174
NEW ECTYPE,ECNDC,ECZERO,K,ECPROD,ECFCHAR,ECSTOCK,ECXPHA,LOCAL
+2 SET ECTYPE=0
SET ECXPHA=""
+3 ; call pharmacy drug file (#50) api via ecxutl5
+4 SET ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
+5 SET ECNDC=$PIECE(ECXPHA,U,3)
+6 SET ECNDC=$$RJ^XLFSTR($PIECE(ECNDC,"-"),6,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",3),2,0)
SET ECNDC=$TRANSLATE(ECNDC,"*",0)
+7 ;174
SET ECZERO=1
SET ECSTOCK=0
SET LOCAL=0
FOR K=1:1:$LENGTH(ECNDC)
Begin DoDot:1
+8 SET ECFCHAR=$EXTRACT(ECNDC,K)
+9 ;174 If NDC is blank and marked with LCL or LCD, stop processing
IF $EXTRACT(ECNDC,1)="L"
SET LOCAL=1
QUIT
+10 IF ECFCHAR="S"
SET ECSTOCK=1
QUIT
+11 IF ECFCHAR'=0
SET ECZERO=0
QUIT
End DoDot:1
if 'ECZERO!ECSTOCK!LOCAL
QUIT
+12 IF ECZERO!ECSTOCK!(ECNDC["N/A")
SET ECTYPE=2
+13 SET ECPROD=$PIECE(ECXPHA,U,6)
SET ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
+14 IF ECTYPE
IF 'ECPROD
SET ECTYPE=3
+15 IF 'ECTYPE
IF 'ECPROD
SET ECTYPE=1
+16 IF ECTYPE
DO FILE
+17 QUIT
+18 ;
FILE ; file record
+1 NEW ECFKEY,ECGNAME,STATS,ECCOUNT,QTY,COST,ECCOST
+2 ; create new record if none exists for this drug
+3 IF '$DATA(^TMP($JOB,ECDRG))
Begin DoDot:1
+4 SET ECFKEY=ECPROD_ECNDC
+5 SET ECGNAME=$PIECE($GET(^PSDRUG(ECDRG,0)),U)
+6 SET ^TMP($JOB,ECDRG)=ECGNAME_U_ECFKEY_U_ECPRC_U_ECTYPE
+7 SET ^TMP($JOB,ECDRG,0)="0^0^0"
End DoDot:1
+8 ; add stats to record
+9 SET STATS=^TMP($JOB,ECDRG,0)
+10 SET ECCOUNT=$PIECE(STATS,U)
SET QTY=$PIECE(STATS,U,2)
SET COST=$PIECE(STATS,U,3)
+11 SET ECCOUNT=ECCOUNT+1
+12 SET ECCOST=ECQTY*ECPRC
+13 SET ECQTY=ECQTY+QTY
SET ECCOST=ECCOST+COST
+14 SET ^TMP($JOB,ECDRG,0)=ECCOUNT_U_ECQTY_U_ECCOST
+15 QUIT
+16 ;
EXIT SET ECXERR=1
QUIT
