APSPRCUI.m

APSPRCUI ;MSC/JS  QUERY APELON FOR RXNORM VALUE FOR DRUG NDC OR DRUG VUID ;11-Oct-2013 13:15;DU

 ;;7.0;IHS PHARMACY MODIFICATIONS;**1017**;Sep 23, 2004;Build 40

 ;

 ;     TAGS:

 ;     LIST    - List Drug file #50 entry RXNorm field

 ;     QUERY   - Query Apelon site for selected Drug file entry, defaults to NDC code, or VUID (if it exists)

 ;     UPONE   - Set Drug file entry RXCUI field with Apelon RXNorm value returned, or manually entered

 ;     UPALL   - Set All Drug file entries RXCUI field with Apelon RXNorm value returned

 ;     QRXNORM - Query Drug file entry passing parameter IEN50

 ;     SQUERY  - API called from PSSCOMMON input template to add RXNORM code for new Drug file entry

 ;     SUPALL  - Tasked Set All Drug file entries RXCUI field with Apelon RXNorm value returned

 ;     ONEUP   - Menu option - Set Drug file entry RXCUI field with Apelon RXNorm value returned, or manually entered

 ;

 Q  ; -- interactive use call tag MAIN

 ;

MAIN ;

 I $G(DUZ)="" S DUZ=.5,DUZ(0)="@"

 S U="^" D HOME^%ZIS

 S $P(LINE,"-",80)=""

 D NDC

 S NOWI=$$NOW^XLFDT S Y=NOWI X ^DD("DD") S NOWE=Y

 NEW DIR,X,Y

 K DIR,X,Y

 S DIR(0)="S^Q:Query;L:List File RXNorm Codes (STATS);O:Update One RXNorm Entry;A:Update ALL RXNorm Entries;X:Exit"

 S DIR("B")="X"

 W ! D ^DIR

 G EXIT:Y=0!($D(DIRUT))

 I Y="L" D LIST G MAIN

 I Y="Q" D QUERY G MAIN

 I Y="O" D UPONE G MAIN

 I Y="A" D UPALL G MAIN

 I Y="X" G EXIT

 G EXIT

 ;

LIST ;

 NEW DIR,X,Y

 S DIR(0)="Y",DIR("A")="List the Drug File RXNorm data",DIR("B")="Y"

 W ! D ^DIR

 G EXIT:Y=0!($D(DIRUT))

 I Y=1 D

 .W @IOF,!!,"DRUG FILE RXNORM LIST",?50,"DATE: ",NOWE,!,LINE,!,"DRUG"

 .NEW IEN50

 .S (IEN50,TOTAL,TOTRXY,TOTRXN,TOTNDCY,TOTNDCN)=0

 .F  S IEN50=$O(^PSDRUG(IEN50)) Q:IEN50=""  D

 ..Q:'$D(^PSDRUG(IEN50,0))

 ..NEW DRUGNM S DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E") S DRUGNM=DRUGNM_" ("_IEN50_")"

 ..NEW NDC S NDC=$$GET1^DIQ(50,IEN50,31,"E")

 ..NEW RXNORM S RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E")

 ..I $G(RXNORM)]"" S TOTRXY=TOTRXY+1

 ..I $G(RXNORM)="" S TOTRXN=TOTRXN+1

 ..I $G(NDC)]"" S TOTNDCY=TOTNDCY+1

 ..I $G(NDC)="" S TOTNDCN=TOTNDCN+1

 ..W !,"DRUG: ",DRUGNM

 ..W !?5,"NDC: ",NDC,?35,"RXNorm: ",RXNORM

 ..S TOTAL=TOTAL+1

 ..Q

 W !!,"TOTAL DRUG ENTRIES WITH RXNORM CODES: ",TOTRXY

 W !,"TOTAL DRUG ENTRIES WITH NO RXNORM CODES: ",TOTRXN

 W !,"TOTAL DRUG ENTRIES WITH NDC CODES: ",TOTNDCY

 W !,"TOTAL DRUG ENTRIES WITH NO NDC CODES: ",TOTNDCN

 W !!,"TOTAL DRUG ENTRIES: ",TOTAL

 Q

 ;

QUERY ;

 NEW DIR,X,Y,IEN50

 S DIR(0)="P^50:EMZ",DIR("A")="Enter DRUG file entry"

 W ! D ^DIR

 Q:$D(DIRUT)

 S IEN50=+Y

 Q:'$D(^PSDRUG(IEN50,0))

 NEW DRUGNM S DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E") S DRUGNM=DRUGNM_" ("_IEN50_")"

 NEW NDC S NDC=$$GET1^DIQ(50,IEN50,31,"E") S:NDC="" NDC="NONE"

 NEW RXNORM S RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E") S:RXNORM="" RXNORM="NONE"

 W !,"DRUG: ",DRUGNM,!,?30,"NDC:",?40,NDC,!?30,"RXNorm:",?40,RXNORM

 Q

 ; -- if APSPDIS parameter set, make a 'quiet' call

SQUERY(IEN50,APSPDIS) ;

 N RXNORM,NDC,NDCPAR

 S RXNORM=""

 I '$D(^PSDRUG(IEN50,0))="" Q ""

 D NDC

 I NDCPAR="P" S NDC=$$NDC^APSPES4(IEN50)

 E  S NDC=$$GET1^DIQ(50,IEN50,31,"E") S:NDC="" NDC="NONE"

 I NDCPAR="L" I NDC="NONE" D  ; alternate lookup NDC code from VA PRODUCT file when local NDC field #31 is null

 .S NDC=$$NDC^APSPES4(IEN50)

 .S:NDC="" NDC="NONE"

 I NDC="NONE" Q "-1^NDC not found for DRUG entry"

 NEW DRUGNM S DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E") S DRUGNM=DRUGNM_" ("_IEN50_")"

 NEW NDCAP S NDCAP=NDC

 S RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E")

 D APELON(.RXNORM)

 Q RXNORM

 ;

 ; -- KIDS Post-Install Update - Queued update for all Drug file entries

SUPALL ;

 N APSPARR

 S APSPARR(1)=""

 S APSPARR(2)="Checking the Apelon utility installation..."

 S APSPARR(3)=""

 D MES^XPDUTL(.APSPARR) K APSPARR

 ;

 NEW APELYES S APELYES=$$TEST^CIAUOS("DI2RX^BSTSAPI")

 ;

 N APSPARR

 S APSPARR(1)=""

 I APELYES S APSPARR(2)="Tasking DRUG File #50 RXCUI field update..."

 E  S APSPARR(2)="The Apelon utility has not been installed, aborting update..."

 S APSPARR(3)=""

 D MES^XPDUTL(.APSPARR) K APSPARR

 Q:APELYES=0

 ;-- schedule TM job to run 'NOW' --

 S ZTIO=""

 ;S ZTDTH=$H

 S ZTRTN="DQ^APSPRCUI"

 S ZTDESC="Tasked Update FILE #50 'RXCUI' field from KIDs build "_$G(XPDNM)

 I $G(XPDNM)]"" S ZTSAVE("XPDNM")=""

 D ^%ZTLOAD K IO("Q")

 D HOME^%ZIS

 N APSPARR

 S APSPARR(1)=""

 S APSPARR(2)="The update for DRUG file field RXCUI"_$S($G(ZTSK)]"":" is tasked #"_ZTSK,1:" has NOT been tasked")

 S APSPARR(3)=""

 D MES^XPDUTL(.APSPARR) K APSPARR

 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK

 Q

 ;

NDC ; -- check XPAR parameter APSP RXNORM NDC LOOKUP for NDC lookup method, default value is 'P' - VA PRODUCT NDC lookup

 S NDCDIV=$$GET^XPAR("DIV","APSP RXNORM NDC LOOKUP")

 S NDCSYS=$$GET^XPAR("SYS","APSP RXNORM NDC LOOKUP")

 I NDCDIV="" S NDCPAR=NDCSYS S:NDCPAR="" NDCPAR="P" Q

 I NDCDIV]"" D

 .I $G(DUZ(2))="" S NDCPAR=NDCSYS S:NDCPAR="" NDCPAR="P" Q

 .NEW XPIEN

 .S XPIEN="",XPIEN=$O(^XTV(8989.51,"B","APSP RXNORM NDC LOOKUP",XPIEN))

 .I XPIEN="" S NDCPAR="P" Q

 .NEW XPAC,FLG

 .S XPAC=""

 .S FLG=0

 .F  S XPAC=$O(^XTV(8989.5,"AC",XPIEN,XPAC)) Q:XPAC=""!(FLG=1)  D

 ..I XPAC[";DIC(4," I XPAC[$G(DUZ(2)) S NDCPAR=NDCDIV,FLG=1 Q

 .S:$G(NDCPAR)="" NDCPAR=NDCSYS S:NDCPAR="" NDCPAR="P"

 Q

 ;

TMPGBL(X) ;EP

 K ^TMP("APSPRCUI",$J) Q $NA(^($J))

 ;

DQ ; -- tasked update from KIDs Post-Install for ALL Drug file entries job starts here

 S APSPDIS=1 ; -- skip the Apelon call dialog

 D NDC

 NEW IEN50,RXNORM

 S IEN50=0,RXNORM=""

 F  S IEN50=$O(^PSDRUG(IEN50)) Q:IEN50=""  D

 .Q:'$D(^PSDRUG(IEN50,0))

 .I NDCPAR="P" S NDC=$$NDC^APSPES4(IEN50)

 .E  S NDC=$$GET1^DIQ(50,IEN50,31,"E") S:NDC="" NDC="NONE"

 .I NDCPAR="L" I NDC="NONE" D  ; alternate lookup NDC code from VA PRODUCT file when local NDC field #31 is null

 ..S NDC=$$NDC^APSPES4(IEN50)

 ..S:NDC="" NDC="NONE"

 .I NDC="NONE" Q

 .NEW NDCAP S NDCAP=NDC

 .D APELON(RXNORM)

 K APSPDIS,NDC,NDCDIV,NDCPAR,NDCSYS

 Q

 ;

UPONE ;

 W @IOF,!!

 W !,"This option will update a DRUG file entry RXNorm field using the Apelon Tool",!,"or alternatively by data entry.",!

 NEW DIR,X,Y

 K DIR,X,Y

 S DIR(0)="Y",DIR("A")="Do you want to update the Drug File RXNorm data using the Apelon Tool",DIR("B")="Y"

 S DIR("?")="Enter 'NO' to manually enter the RXNorm data, or '^' to quit."

 W ! D ^DIR

 Q:$D(DIRUT)

 S USEAP=Y

 I USEAP I '$$TEST^CIAUOS("DI2RX^BSTSAPI") W !!,"The Apelon utility has not been installed on this account, aborting update." Q

 K DIR,X,Y

 S DIR(0)="P^50:EMZ",DIR("A")="Enter DRUG file entry"

 W ! D ^DIR

 Q:$D(DIRUT)

 K IEN50 S IEN50=+Y

 Q:'$D(^PSDRUG(IEN50,0))

 D NDC

 W:'USEAP !!,$S(NDCPAR="L":"Using local DRUG file NDC data...",1:"Using VA PRODUCT file NDC data...")

 W:USEAP !!,$S(NDCPAR="L":"Using local DRUG file NDC data for Apelon query...",1:"Using VA PRODUCT file NDC value used for Apelon query...")

 NEW DRUGNM S DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E") S DRUGNM=DRUGNM_" ("_IEN50_")"

 NEW NDC

 I NDCPAR="P" S NDC=$$NDC^APSPES4(IEN50)

 E  S NDC=$$GET1^DIQ(50,IEN50,31,"E") S:NDC="" NDC="NONE"

 I NDCPAR="L" I NDC="NONE" D  ; alternate lookup NDC code from VA PRODUCT file when local NDC field #31 is null

 .W !,"Local NDC field not set, alternately using NDC code from VA PRODUCT file...",!

 .S NDC=$$NDC^APSPES4(IEN50)

 S:NDC="" NDC="NONE"

 NEW RXNORM S RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E") S:RXNORM="" RXNORM="NONE"

 W !,DRUGNM,?55,NDC

 I USEAP I NDC="NONE" W !!,"No NDC code found for this entry, cannot query Apelon for update.",! Q

 NEW NDCAP S NDCAP=NDC

 I 'USEAP D FLDEDIT(IEN50)

 I USEAP D APELON(RXNORM)

 Q

 ;

UPALL ;

 I '$$TEST^CIAUOS("DI2RX^BSTSAPI") W !!,"The Apelon utility has not been installed on this account, aborting update." Q

 NEW DIR,X,Y

 K DIR,X,Y

 S DIR(0)="Y",DIR("A")="Update the Drug File RXNorm data for ALL entries",DIR("B")="Y"

 W ! D ^DIR

 G EXIT:Y=0!($D(DIRUT))

 D NDC

 NEW IEN50

 S IEN50=0

 F  S IEN50=$O(^PSDRUG(IEN50)) Q:IEN50=""  D

 .Q:'$D(^PSDRUG(IEN50,0))

 .NEW DRUGNM S DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E") S DRUGNM=DRUGNM_" ("_IEN50_")"

 .W !!,$S(NDCPAR="L":"Checking local DRUG file NDC data for Apelon query...",1:"VA PRODUCT file NDC value used for Apelon query...")

 .NEW NDC

 .I NDCPAR="P" S NDC=$$NDC^APSPES4(IEN50)

 .E  S NDC=$$GET1^DIQ(50,IEN50,31,"E") S:NDC="" NDC="NONE"

 .I NDCPAR="L" I NDC="NONE" D  ; alternate lookup NDC code from VA PRODUCT file when local NDC field #31 is null

 ..W !,"Local NDC field not set, alternately using NDC code from VA PRODUCT file...",!

 ..S NDC=$$NDC^APSPES4(IEN50)

 .S:NDC="" NDC="NONE"

 .NEW RXNORM S RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E") S:RXNORM="" RXNORM="NONE"

 .I NDC="NONE" W !,"Skipping entry ",DRUGNM," no NDC code",! Q

 .W !,DRUGNM,?55,NDC

 .NEW NDCAP S NDCAP=NDC

 .D APELON(RXNORM)

 Q

 ; Query DRUG file entry, returns IEN ^ Drug Name ^ NDC Code ^ RXNorm

 ; Input = DRUG file #50 IEN

QRXNORM(RET,IEN50) ;

 I $G(IEN50)="" Q "-1^Missing Drug file #50 IEN parameter"

 I '$D(^PSDRUG(IEN50,0))="" Q ""

 NEW INFO50

 S INFO50=0

 D NDC

 I NDCPAR="P" S NDC=$$NDC^APSPES4(IEN50)

 E  S NDC=$$GET1^DIQ(50,IEN50,31,"E") S:NDC="" NDC="NONE"

 I NDCPAR="L" I NDC="NONE" D  ; alternate lookup NDC code from VA PRODUCT file when local NDC field #31 is null

 .S NDC=$$NDC^APSPES4(IEN50)

 .S:NDC="" NDC="NONE"

 NEW DRUGNM S DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E") S DRUGNM=DRUGNM_" ("_IEN50_")"

 NEW RXNORM S RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E") S:RXNORM="" RXNORM="NONE"

 S INFO50=$G(IEN50)_U_$G(DRUGNM)_U_$G(NDC)_U_$G(RXNORM)

 Q INFO50

 ;

FLDEDIT(IEN50) ; -- update RXCUI field with data entry

 NEW DIR,X,Y,RXCUI

 K DIR,X,Y

 S DIR(0)="N^1:9999999",DIR("A")="Enter the RXNorm numeric code"

 W ! D ^DIR

 Q:$D(DIRUT)

 S RXCUI=Y

 NEW DA,DIE,DR,X,Y

 K DA,DIE,DR,X,Y

 S DA=IEN50

 S DIE="^PSDRUG("

 S DR="9999999.27///^S X=RXCUI"

 D ^DIE

 S RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E") S:RXNORM="" RXNORM="NONE"

 W !,$S(RXNORM=RXCUI:"ENTRY UPDATED",1:"ENTRY *NOT* UPDATED")

 I RXNORM=RXCUI W " - RXCUI field set to:    ",RXNORM

 Q

 ;

APELON(RXNORM) ; -- query Apelon site for drug NDC code, if RXCUI data returned updated DRUG file entry(s)

 ;               -- if $G(APSPDIS)="", display dialog

 N NDCAPL,RXCUI,IN,ZDATA,UPOK,VUID,VUIDOK

 S RXNORM=""

 Q:$G(NDCAP)=""

 S UPOK=0

 S NDCAP=$$STRIP^XLFSTR(NDCAP,"-")

 S NDCAPL=$L(NDCAP) I NDCAPL>11 I $E(NDCAP,1)=0 S NDCAP=$E(NDCAP,2,999) ; strip off leading 0

 W:$G(APSPDIS)="" !,"Querying Apelon site..."

 S IN=NDCAP_"^N" S ZDATA=$$DI2RX^BSTSAPI(IN)

 I ZDATA="" D

 .W:$G(APSPDIS)="" "NDC query failed, trying VUID query..."

 .D VUID

 .I VUIDOK=0 W:$G(APSPDIS)="" !,"VUID code not onfile, skipping entry"

 .I VUIDOK=1 D

 ..;Input (from DI2RX^BSTSAPIF)

 ..;  IN - P1 - The exact term to lookup

 ..;     - P2 - Lookup Type (N-NDC,V-VUID)

 ..S IN=VUID_"^V" S ZDATA=$$DI2RX^BSTSAPI(IN)

 ;First try for trade name (3rd piece), if not there use the data in field 1

 S RXCUI=$P(ZDATA,U,3)

 S TTY=$P(ZDATA,U,5)

 I RXCUI="" S RXCUI=$P(ZDATA,U,1)

 I $G(RXCUI)]"" S UPOK=1

 I UPOK=0 Q

 I UPOK=1 D

 .NEW DA,DIE,DR,X,Y

 .S DA=IEN50

 .S DIE="^PSDRUG("

 .S DR="9999999.27///^S X=RXCUI"

 .D ^DIE

 .S RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E") S:RXNORM="" RXNORM="NONE"

 .W:$G(APSPDIS)="" $S(RXNORM=RXCUI:"ENTRY UPDATED",1:"ENTRY *NOT* UPDATED")

 .I RXNORM=RXCUI W:$G(APSPDIS)="" " - RXCUI field set to:    ",RXNORM

 .S RXNORM=RXCUI_U_TTY

 Q

 ;

VUID ; -- alternate Drug VUID lkup here if no NDC available

 S VUIDOK=0

 N VAPNAME,NDNODE,PSNF

 S NDNODE=$G(^PSDRUG(IEN50,"ND")),VAPNAME=$P(NDNODE,U,2)

 Q:VAPNAME=""

 S PSNF="",PSNF=$O(^PSNDF(50.68,"B",VAPNAME,PSNF))

 Q:PSNF=""

 N VUIDND,VUIDMSTR

 S VUIDND=$G(^PSNDF(50.68,PSNF,"VUID"))

 Q:VUIDND=""

 S VUID=$P(VUIDND,U,1),VUIDMSTR=$P(VUIDND,U,2)

 Q:VUID=""!(VUIDMSTR="")

 I VUIDMSTR=1 I $L(VUID)=7 S VUIDOK=1

 Q

 ;

ONEUP ; -- XQ menu option to update RXNorm field for DRUG file entry

 S U="^" D HOME^%ZIS

 NEW USEAP,IEN50,NDC,NDCDIV,NDCSYS,NDCPAR,DRUGNM

 W @IOF,!!

 W !,"This option will update a DRUG file entry RXNorm field using the Apelon Tool",!,"or alternatively by data entry.",!

 NEW DIR,X,Y

 K DIR,X,Y

 S DIR(0)="Y",DIR("A")="Do you want to update the Drug File RXNorm data using the Apelon Tool",DIR("B")="Y"

 S DIR("?")="Enter 'NO' to manually enter the RXNorm data, or '^' to quit."

 W ! D ^DIR

 G EXIT:$D(DIRUT)

 S USEAP=Y

 I USEAP I '$$TEST^CIAUOS("DI2RX^BSTSAPI") W !!,"The Apelon utility has not been installed on this account, aborting update." G EXIT

 K DIR,X,Y

 S DIR(0)="P^50:EMZ",DIR("A")="Enter DRUG file entry"

 W ! D ^DIR

 G EXIT:$D(DIRUT)

 K IEN50 S IEN50=+Y

 I '$D(^PSDRUG(IEN50,0)) W !!,"DRUG file entry not available for editing",! G ONEUP

 D NDC

 W:'USEAP !!,$S(NDCPAR="L":"Using local DRUG file NDC data...",1:"Using VA PRODUCT file NDC data...")

 W:USEAP !!,$S(NDCPAR="L":"Using local DRUG file NDC data for Apelon query...",1:"Using VA PRODUCT file NDC value used for Apelon query...")

 NEW DRUGNM S DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E") S DRUGNM=DRUGNM_" ("_IEN50_")"

 NEW NDC

 I NDCPAR="P" S NDC=$$NDC^APSPES4(IEN50)

 E  S NDC=$$GET1^DIQ(50,IEN50,31,"E") S:NDC="" NDC="NONE"

 I NDCPAR="L" I NDC="NONE" D  ; alternate lookup NDC code from VA PRODUCT file when local NDC field #31 is null

 .W !,"Local NDC field not set, alternately using NDC code from VA PRODUCT file...",!

 .S NDC=$$NDC^APSPES4(IEN50)

 S:NDC="" NDC="NONE"

 NEW RXNORM S RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E") S:RXNORM="" RXNORM="NONE"

 W !,DRUGNM,?55,NDC

 I USEAP I NDC="NONE" W !!,"No NDC code found for this entry, cannot query Apelon for update.",! G ONEUP

 NEW NDCAP S NDCAP=NDC

 I 'USEAP D FLDEDIT(IEN50)

 I USEAP D APELON(RXNORM)

 NEW DIR,X,Y

 S DIR(0)="E",DIR("A")="Press RETURN to continue" W !! D ^DIR

 G ONEUP

 ;

EXIT ;

 K DIRUT,IN,LINE,NOWE,NOWI,TOTAL,TOTNDCY,TOTNDCN,TOTRXN,TOTRXY,VUIDOK,IEN50,ZDATA

 K APSPDIS,NDC,NDCAPL,UPOK,RXCUI,NDCDIV,NDCSYS,NDCPAR,USEAP

 Q

ROUTES ;Enter old SNOMED medication routes

 N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,DIR

 S ZTRTN="UPROUTE^APSPRCUI",ZTIO="",ZTSAVE("DUZ")=""

 W !,"Tasking MEDICATION ROUTE #51.2 SNOMED CODE Update"

 S ZTDESC="Store SNOMED on med routes mapped to standard route file"

 D ^%ZTLOAD

 I $G(ZTSK) D

 .W !!,"A task has been queued in the background."

 .W !,"  The task number is "_$G(ZTSK)_"."

 Q

UPROUTE ;Update local medication routes that are mapped

 N MEDIEN,PSSDMRNW,PSSMRNM,SNOMED,ZDATA,IN,ERR,FDA,IENS,FNUM

 S MEDIEN=0  F  S MEDIEN=$O(^PS(51.2,MEDIEN)) Q:'+MEDIEN  D

 .S PSSDMRNW=$P($G(^PS(51.2,MEDIEN,1)),"^")

 .Q:PSSDMRNW=""

 .S PSSMRNM=$P($G(^PS(51.23,PSSDMRNW,0)),"^")

 .S IN=PSSMRNM_"^32774" S ZDATA=$$ASSOC^BSTSAPI(IN)

 .S SNOMED=$P(ZDATA,U,1)

 .S FNUM=51.2

 .S IENS=MEDIEN_","

 .S FDA=$NA(FDA(FNUM,IENS))

 .S @FDA@(9999999.01)=SNOMED

 .D FILE^DIE("E","FDA","ERR")

 Q

APSPRCUI  ;MSC/JS  QUERY APELON FOR RXNORM VALUE FOR DRUG NDC OR DRUG VUID ;11-Oct-2013 13:15;DU

 +1       ;;7.0;IHS PHARMACY MODIFICATIONS;**1017**;Sep 23, 2004;Build 40

 +2       ;

 +3       ;     TAGS:

 +4       ;     LIST    - List Drug file #50 entry RXNorm field

 +5       ;     QUERY   - Query Apelon site for selected Drug file entry, defaults to NDC code, or VUID (if it exists)

 +6       ;     UPONE   - Set Drug file entry RXCUI field with Apelon RXNorm value returned, or manually entered

 +7       ;     UPALL   - Set All Drug file entries RXCUI field with Apelon RXNorm value returned

 +8       ;     QRXNORM - Query Drug file entry passing parameter IEN50

 +9       ;     SQUERY  - API called from PSSCOMMON input template to add RXNORM code for new Drug file entry

 +10      ;     SUPALL  - Tasked Set All Drug file entries RXCUI field with Apelon RXNorm value returned

 +11      ;     ONEUP   - Menu option - Set Drug file entry RXCUI field with Apelon RXNorm value returned, or manually entered

 +12      ;

 +13      ; -- interactive use call tag MAIN

           QUIT 

 +14      ;

MAIN      ;

 +1        IF $GET(DUZ)=""

               SET DUZ=.5

               SET DUZ(0)="@"

 +2        SET U="^"

           DO HOME^%ZIS

 +3        SET $PIECE(LINE,"-",80)=""

 +4        DO NDC

 +5        SET NOWI=$$NOW^XLFDT

           SET Y=NOWI

           XECUTE ^DD("DD")

           SET NOWE=Y

 +6        NEW DIR,X,Y

 +7        KILL DIR,X,Y

 +8        SET DIR(0)="S^Q:Query;L:List File RXNorm Codes (STATS);O:Update One RXNorm Entry;A:Update ALL RXNorm Entries;X:Exit"

 +9        SET DIR("B")="X"

 +10       WRITE !

           DO ^DIR

 +11       IF Y=0!($DATA(DIRUT))

               GOTO EXIT

 +12       IF Y="L"

               DO LIST

               GOTO MAIN

 +13       IF Y="Q"

               DO QUERY

               GOTO MAIN

 +14       IF Y="O"

               DO UPONE

               GOTO MAIN

 +15       IF Y="A"

               DO UPALL

               GOTO MAIN

 +16       IF Y="X"

               GOTO EXIT

 +17       GOTO EXIT

 +18      ;

LIST      ;

 +1        NEW DIR,X,Y

 +2        SET DIR(0)="Y"

           SET DIR("A")="List the Drug File RXNorm data"

           SET DIR("B")="Y"

 +3        WRITE !

           DO ^DIR

 +4        IF Y=0!($DATA(DIRUT))

               GOTO EXIT

 +5        IF Y=1

               Begin DoDot:1

 +6                WRITE @IOF,!!,"DRUG FILE RXNORM LIST",?50,"DATE: ",NOWE,!,LINE,!,"DRUG"

 +7                NEW IEN50

 +8                SET (IEN50,TOTAL,TOTRXY,TOTRXN,TOTNDCY,TOTNDCN)=0

 +9                FOR 

                       SET IEN50=$ORDER(^PSDRUG(IEN50))

                       IF IEN50=""

                           QUIT 

                       Begin DoDot:2

 +10                       IF '$DATA(^PSDRUG(IEN50,0))

                               QUIT 

 +11                       NEW DRUGNM

                           SET DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E")

                           SET DRUGNM=DRUGNM_" ("_IEN50_")"

 +12                       NEW NDC

                           SET NDC=$$GET1^DIQ(50,IEN50,31,"E")

 +13                       NEW RXNORM

                           SET RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E")

 +14                       IF $GET(RXNORM)]""

                               SET TOTRXY=TOTRXY+1

 +15                       IF $GET(RXNORM)=""

                               SET TOTRXN=TOTRXN+1

 +16                       IF $GET(NDC)]""

                               SET TOTNDCY=TOTNDCY+1

 +17                       IF $GET(NDC)=""

                               SET TOTNDCN=TOTNDCN+1

 +18                       WRITE !,"DRUG: ",DRUGNM

 +19                       WRITE !?5,"NDC: ",NDC,?35,"RXNorm: ",RXNORM

 +20                       SET TOTAL=TOTAL+1

 +21                       QUIT 

                       End DoDot:2

               End DoDot:1

 +22       WRITE !!,"TOTAL DRUG ENTRIES WITH RXNORM CODES: ",TOTRXY

 +23       WRITE !,"TOTAL DRUG ENTRIES WITH NO RXNORM CODES: ",TOTRXN

 +24       WRITE !,"TOTAL DRUG ENTRIES WITH NDC CODES: ",TOTNDCY

 +25       WRITE !,"TOTAL DRUG ENTRIES WITH NO NDC CODES: ",TOTNDCN

 +26       WRITE !!,"TOTAL DRUG ENTRIES: ",TOTAL

 +27       QUIT 

 +28      ;

QUERY     ;

 +1        NEW DIR,X,Y,IEN50

 +2        SET DIR(0)="P^50:EMZ"

           SET DIR("A")="Enter DRUG file entry"

 +3        WRITE !

           DO ^DIR

 +4        IF $DATA(DIRUT)

               QUIT 

 +5        SET IEN50=+Y

 +6        IF '$DATA(^PSDRUG(IEN50,0))

               QUIT 

 +7        NEW DRUGNM

           SET DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E")

           SET DRUGNM=DRUGNM_" ("_IEN50_")"

 +8        NEW NDC

           SET NDC=$$GET1^DIQ(50,IEN50,31,"E")

           IF NDC=""

               SET NDC="NONE"

 +9        NEW RXNORM

           SET RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E")

           IF RXNORM=""

               SET RXNORM="NONE"

 +10       WRITE !,"DRUG: ",DRUGNM,!,?30,"NDC:",?40,NDC,!?30,"RXNorm:",?40,RXNORM

 +11       QUIT 

 +12      ; -- if APSPDIS parameter set, make a 'quiet' call

SQUERY(IEN50,APSPDIS) ;

 +1        NEW RXNORM,NDC,NDCPAR

 +2        SET RXNORM=""

 +3        IF '$DATA(^PSDRUG(IEN50,0))=""

               QUIT ""

 +4        DO NDC

 +5        IF NDCPAR="P"

               SET NDC=$$NDC^APSPES4(IEN50)

 +6       IF '$TEST

               SET NDC=$$GET1^DIQ(50,IEN50,31,"E")

               IF NDC=""

                   SET NDC="NONE"

 +7       ; alternate lookup NDC code from VA PRODUCT file when local NDC field #31 is null

           IF NDCPAR="L"

               IF NDC="NONE"

                   Begin DoDot:1

 +8                    SET NDC=$$NDC^APSPES4(IEN50)

 +9                    IF NDC=""

                           SET NDC="NONE"

                   End DoDot:1

 +10       IF NDC="NONE"

               QUIT "-1^NDC not found for DRUG entry"

 +11       NEW DRUGNM

           SET DRUGNM=$$GET1^DIQ(50,IEN50,.01,"E")

           SET DRUGNM=DRUGNM_" ("_IEN50_")"

 +12       NEW NDCAP

           SET NDCAP=NDC

 +13       SET RXNORM=$$GET1^DIQ(50,IEN50,9999999.27,"E")

 +14       DO APELON(.RXNORM)

 +15       QUIT RXNORM

 +16      ;

 +17      ; -- KIDS Post-Install Update - Queued update for all Drug file entries

SUPALL    ;

 +1        NEW APSPARR

 +2        SET APSPARR(1)=""

 +3        SET APSPARR(2)="Checking the Apelon utility installation..."

 +4        SET APSPARR(3)=""

 +5        DO MES^XPDUTL(.APSPARR)

           KILL APSPARR

 +6       ;

 +7        NEW APELYES

           SET APELYES=$$TEST^CIAUOS("DI2RX^BSTSAPI")

 +8       ;

 +9        NEW APSPARR

 +10       SET APSPARR(1)=""

 +11       IF APELYES

               SET APSPARR(2)="Tasking DRUG File #50 RXCUI field update..."

 +12      IF '$TEST

               SET APSPARR(2)="The Apelon utility has not been installed, aborting update..."

 +13       SET APSPARR(3)=""

 +14       DO MES^XPDUTL(.APSPARR)

           KILL APSPARR

 +15       IF APELYES=0

               QUIT 

 +16      ;-- schedule TM job to run 'NOW' --

 +17       SET ZTIO=""

 +18      ;S ZTDTH=$H

 +19       SET ZTRTN="DQ^APSPRCUI"

 +20       SET ZTDESC="Tasked Update FILE #50 'RXCUI' field from KIDs build "_$GET(XPDNM)

 +21       IF $GET(XPDNM)]""

               SET ZTSAVE("XPDNM")=""

 +22       DO ^%ZTLOAD

           KILL IO("Q")

 +23       DO HOME^%ZIS

 +24       NEW APSPARR

 +25       SET APSPARR(1)=""

 +26       SET APSPARR(2)="The update for DRUG file field RXCUI"_$SELECT($GET(ZTSK)]"":" is tasked #"_ZTSK,1:" has NOT been tasked")

 +27       SET APSPARR(3)=""

 +28       DO MES^XPDUTL(.APSPARR)

           KILL APSPARR

 +29       KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK

 +30       QUIT 

 +31      ;

NDC       ; -- check XPAR parameter APSP RXNORM NDC LOOKUP for NDC lookup method, default value is 'P' - VA PRODUCT NDC lookup

 +1        SET NDCDIV=$$GET^XPAR("DIV","APSP RXNORM NDC LOOKUP")

 +2        SET NDCSYS=$$GET^XPAR("SYS","APSP RXNORM NDC LOOKUP")

 +3        IF NDCDIV=""

               SET NDCPAR=NDCSYS

               IF NDCPAR=""

                   SET NDCPAR="P"

               QUIT 

 +4        IF NDCDIV]""

               Begin DoDot:1

 +5                IF $GET(DUZ(2))=""

                       SET NDCPAR=NDCSYS

                       IF NDCPAR=""

                           SET NDCPAR="P"

                       QUIT 

 +6                NEW XPIEN

 +7                SET XPIEN=""

                   SET XPIEN=$ORDER(^XTV(8989.51,"B","APSP RXNORM NDC LOOKUP",XPIEN))

 +8                IF XPIEN=""

                       SET NDCPAR="P"

                       QUIT 

 +9                NEW XPAC,FLG

 +10               SET XPAC=""

 +11               SET FLG=0

 +12               FOR 

                       SET XPAC=$ORDER(^XTV(8989.5,"AC",XPIEN,XPAC))

                       IF XPAC=""!(FLG=1)

                           QUIT 

                       Begin DoDot:2

 +13                       IF XPAC[";DIC(4,"

                               IF XPAC[$GET(DUZ(2))

                                   SET NDCPAR=NDCDIV

                                   SET FLG=1

                                   QUIT 

                       End DoDot:2

 +14               IF $GET(NDCPAR)=""

                       SET NDCPAR=NDCSYS

                   IF NDCPAR=""

                       SET NDCPAR="P"

               End DoDot:1

 +15       QUIT 

 +16      ;

TMPGBL(X) ;EP

 +1        KILL ^TMP("APSPRCUI",$JOB)

           QUIT $NAME(^($JOB))

 +2       ;

DQ        ; -- tasked update from KIDs Post-Install for ALL Drug file entries job starts here

 +1       ; -- skip the Apelon call dialog

           SET APSPDIS=1

 +2        DO NDC

 +3        NEW IEN50,RXNORM

 +4        SET IEN50=0

           SET RXNORM=""

 +5        FOR 

               SET IEN50=$ORDER(^PSDRUG(IEN50))

               IF IEN50=""

                   QUIT 

               Begin DoDot:1

 +6                IF '$DATA(^PSDRUG(IEN50,0))

                       QUIT 

 +7                IF NDCPAR="P"

                       SET NDC=$$NDC^APSPES4(IEN50)

 +8               IF '$TEST

                       SET NDC=$$GET1^DIQ(50,IEN50,31,"E")

                       IF NDC=""

                           SET NDC="NONE"

 +9       ; alternate lookup NDC code from VA PRODUCT file when local NDC field #31 is null

                   IF NDCPAR="L"

                       IF NDC="NONE"

                           Begin DoDot:2

 +10                           SET NDC=$$NDC^APSPES4(IEN50)

 +11                           IF NDC=""

                                   SET NDC="NONE"

                           End DoDot:2

 +12               IF NDC="NONE"

                       QUIT 

 +13               NEW NDCAP

                   SET NDCAP=NDC

 +14               DO APELON(RXNORM)

               End DoDot:1

 +15       KILL APSPDIS,NDC,NDCDIV,NDCPAR,NDCSYS

 +16       QUIT 

 +17      ;

UPONE     ;

 +1        WRITE @IOF,!!

 +2        WRITE !,"This option will update a DRUG file entry RXNorm field using the Apelon Tool",!,"or alternatively by data entry.",!