- 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 Feb 18, 2025@23:18:52 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
