APSPRXN ;IHS/MSC/MGH - Unmapp ;04-Sep-2013 12:45;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1017**;Sep 23, 2004;Build 40
EN ;EP
N APSPNUM,APSPQ,APSPARY,APSPNAME,QFLG,APSPCNT
S APSPQ=""
;All or selection of drugs
W @IOF
W !,"Drugs without RxNorm codes",!!
D DEV
Q
DEV ;EP
N XBRP,XBNS
S XBRP="OUT^APSPRXN"
S XBNS="APS*"
D ^XBDBQUE
Q
OUT ;EP
N IEN,NODE,INACT,DRUG,INACTDT,NDC,VA,VANDC,VAIEN,RXNORM
U IO
D HDR
S IEN=0 F S IEN=$O(^PSDRUG(IEN)) Q:IEN=""!('+IEN) D
.S (VANDC,VA)=""
.S INACTDT=$$GET1^DIQ(50,IEN,100,"I")
.Q:+INACTDT
.S RXNORM=$$GET1^DIQ(50,IEN,9999999.27)
.Q:+RXNORM
.S DRUG=$$GET1^DIQ(50,IEN,.01,"E")
.S NDC=$$GET1^DIQ(50,IEN,31)
.S NDC=$TR(NDC,"-","")
.S VAIEN=$$GET1^DIQ(50,IEN,22,"I")
.I VAIEN'="" D
..S VA=$$GET1^DIQ(50.68,VAIEN,.01)
..S VANDC=$$GET1^DIQ(50.68,VAIEN,13)
.I $L(VANDC)=12 S VANDC=$E(VANDC,2,12)
.S APSPARY(DRUG)=IEN_U_NDC_U_VA_U_VANDC
S APSPQ=0
S DRUG="" F S DRUG=$O(APSPARY(DRUG)) Q:DRUG=""!(+APSPQ) D
.S NODE=$G(APSPARY(DRUG))
.S IEN=$P(NODE,U,1),NDC=$P(NODE,U,2),VA=$P(NODE,U,3),VANDC=$P(NODE,U,4)
.W !,IEN,?8,$E(DRUG,1,50),?58,NDC
.W !,?10,$E(VA,1,44),?58,VANDC,!
.I $Y+4>IOSL,IOST["C-" D PAUS Q:APSPQ D HDR
.Q:APSPQ=1
K APSPARY
Q
PAUS ;
N DTOUT,DUOUT,DIR
S DIR("?")="Enter '^' to Halt or Press Return to continue"
S DIR(0)="FO",DIR("A")="Press Return to continue or '^' to Halt"
D ^DIR
I $D(DUOUT) S APSPQ=1
Q
HDR ;
I IOST["C-" W @IOF
W !,"Active Drugs missing RxNorm codes"
W !,"IEN",?8,"Drug Name",?58,"NDC"
W !,?10,"VA Product",?58,"VA NDC",!
Q
REMAP ;EP Option to reset a local NDC and map to RxNorm or just set an RxNorm
N APSPNUM,RXNORM
W @IOF
W !,"Update NDC and RxNorm",!!
ASK ;
N D,DIC,Y,DA,DR,DIE,IEN,NDC,NDCAP,ZDATA,NAME,IN,OUT,%,DLAYGO
W ! S DIC="^PSDRUG(",DIC(0)="QEALMNTV",D="BCAP",DLAYGO=50,DIC("T")="" D IX^DIC K DIC,D I Y<0 Q
S IEN=$P(Y,U,1)
S NAME=$P(Y,U,2)
S APSPNUM=$$DIR^APSPUTIL("S^NDC:Match on NDC;NAME:Name Lookup",,,.APSPQ)
Q:APSPNUM=""!(APSPNUM="^")
S RXNORM=""
I APSPNUM="NDC" D
.S DIE="^PSDRUG(",DR=31,DA=IEN D ^DIE
.S NDC=$$GET1^DIQ(50,IEN,31)
.S NDC=$$STRIP^XLFSTR(NDC,"-")
.S:$L(NDC)=12 NDC=$E(NDC,2,12)
.W !,"Querying Apelon site..."
.S IN=NDC_"^N" S ZDATA=$$DI2RX^BSTSAPI(IN)
.S RXNORM=$P(ZDATA,U,1)
.I RXNORM'="" D STORE(RXNORM) W !,RXNORM_" code stored"
.E W !,"Unable to map this NDC code"
I APSPNUM="NAME" D
.N CNT,CT,RXCODE,DESC,DATA
.K ARR,^TMP($J)
.S CT=0
.W !,"Querying Apelon site..."
.S IN=$P(NAME," ",1)_"^F^1552^^^^P"
.S OUT="^TMP(""APSPRX"",$J)"
.S ZDATA=$$SEARCH^BSTSAPI(.OUT,.IN)
.I ZDATA>0 D
..S CNT="" F S CNT=$O(@OUT@(CNT)) Q:CNT="" D
...;S DATA=$G(@OUT@(CNT,"CON"))_U_$G(@OUT@(CNT,"PRE","TRM"))
...S DATA=$G(@OUT@(CNT,"PRE","TRM"))
...S DESC=$G(@OUT@(CNT,"PRE","TRM"))
...S ^TMP($J,CNT,0)=DATA
...S ^TMP($J,"B",DATA)=CNT
...S CT=CT+1
..S ^TMP($J,0)=U_U_CT_U_CT
..W !!,"Enter ? to see the list of RxNorm Name Matches"
..W !,"Enter ^ to quit the selection",!
..S DIC="^TMP($J," S DIC(0)="AEQ",DIC("A")="Select RxNORM Item: "
..D ^DIC
..S RXNORM=Y
..S RXCODE=$G(^TMP("APSPRX",$J,$P(RXNORM,U,1),"PRE","DSC"))
..I RXCODE'=-1&(RXCODE'="") D STORE(RXCODE) W !,RXCODE_" code stored"
W !!,"Do you want to continue?" S %=2 D YN^DICN
I %=1 G ASK
Q
STORE(RXNORM) ;store code
NEW DA,DIE,DR,X,Y
S DA=IEN
S DIE="^PSDRUG("
S DR="9999999.27///^S X=RXNORM"
D ^DIE
Q
APSPRXN ;IHS/MSC/MGH - Unmapp ;04-Sep-2013 12:45;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1017**;Sep 23, 2004;Build 40
EN ;EP
+1 NEW APSPNUM,APSPQ,APSPARY,APSPNAME,QFLG,APSPCNT
+2 SET APSPQ=""
+3 ;All or selection of drugs
+4 WRITE @IOF
+5 WRITE !,"Drugs without RxNorm codes",!!
+6 DO DEV
+7 QUIT
DEV ;EP
+1 NEW XBRP,XBNS
+2 SET XBRP="OUT^APSPRXN"
+3 SET XBNS="APS*"
+4 DO ^XBDBQUE
+5 QUIT
OUT ;EP
+1 NEW IEN,NODE,INACT,DRUG,INACTDT,NDC,VA,VANDC,VAIEN,RXNORM
+2 USE IO
+3 DO HDR
+4 SET IEN=0
FOR
SET IEN=$ORDER(^PSDRUG(IEN))
IF IEN=""!('+IEN)
QUIT
Begin DoDot:1
+5 SET (VANDC,VA)=""
+6 SET INACTDT=$$GET1^DIQ(50,IEN,100,"I")
+7 IF +INACTDT
QUIT
+8 SET RXNORM=$$GET1^DIQ(50,IEN,9999999.27)
+9 IF +RXNORM
QUIT
+10 SET DRUG=$$GET1^DIQ(50,IEN,.01,"E")
+11 SET NDC=$$GET1^DIQ(50,IEN,31)
+12 SET NDC=$TRANSLATE(NDC,"-","")
+13 SET VAIEN=$$GET1^DIQ(50,IEN,22,"I")
+14 IF VAIEN'=""
Begin DoDot:2
+15 SET VA=$$GET1^DIQ(50.68,VAIEN,.01)
+16 SET VANDC=$$GET1^DIQ(50.68,VAIEN,13)
End DoDot:2
+17 IF $LENGTH(VANDC)=12
SET VANDC=$EXTRACT(VANDC,2,12)
+18 SET APSPARY(DRUG)=IEN_U_NDC_U_VA_U_VANDC
End DoDot:1
+19 SET APSPQ=0
+20 SET DRUG=""
FOR
SET DRUG=$ORDER(APSPARY(DRUG))
IF DRUG=""!(+APSPQ)
QUIT
Begin DoDot:1
+21 SET NODE=$GET(APSPARY(DRUG))
+22 SET IEN=$PIECE(NODE,U,1)
SET NDC=$PIECE(NODE,U,2)
SET VA=$PIECE(NODE,U,3)
SET VANDC=$PIECE(NODE,U,4)
+23 WRITE !,IEN,?8,$EXTRACT(DRUG,1,50),?58,NDC
+24 WRITE !,?10,$EXTRACT(VA,1,44),?58,VANDC,!
+25 IF $Y+4>IOSL
IF IOST["C-"
DO PAUS
IF APSPQ
QUIT
DO HDR
+26 IF APSPQ=1
QUIT
End DoDot:1
+27 KILL APSPARY
+28 QUIT
PAUS ;
+1 NEW DTOUT,DUOUT,DIR
+2 SET DIR("?")="Enter '^' to Halt or Press Return to continue"
+3 SET DIR(0)="FO"
SET DIR("A")="Press Return to continue or '^' to Halt"
+4 DO ^DIR
+5 IF $DATA(DUOUT)
SET APSPQ=1
+6 QUIT
HDR ;
+1 IF IOST["C-"
WRITE @IOF
+2 WRITE !,"Active Drugs missing RxNorm codes"
+3 WRITE !,"IEN",?8,"Drug Name",?58,"NDC"
+4 WRITE !,?10,"VA Product",?58,"VA NDC",!
+5 QUIT
REMAP ;EP Option to reset a local NDC and map to RxNorm or just set an RxNorm
+1 NEW APSPNUM,RXNORM
+2 WRITE @IOF
+3 WRITE !,"Update NDC and RxNorm",!!
ASK ;
+1 NEW D,DIC,Y,DA,DR,DIE,IEN,NDC,NDCAP,ZDATA,NAME,IN,OUT,%,DLAYGO
+2 WRITE !
SET DIC="^PSDRUG("
SET DIC(0)="QEALMNTV"
SET D="BCAP"
SET DLAYGO=50
SET DIC("T")=""
DO IX^DIC
KILL DIC,D
IF Y<0
QUIT
+3 SET IEN=$PIECE(Y,U,1)
+4 SET NAME=$PIECE(Y,U,2)
+5 SET APSPNUM=$$DIR^APSPUTIL("S^NDC:Match on NDC;NAME:Name Lookup",,,.APSPQ)
+6 IF APSPNUM=""!(APSPNUM="^")
QUIT
+7 SET RXNORM=""
+8 IF APSPNUM="NDC"
Begin DoDot:1
+9 SET DIE="^PSDRUG("
SET DR=31
SET DA=IEN
DO ^DIE
+10 SET NDC=$$GET1^DIQ(50,IEN,31)
+11 SET NDC=$$STRIP^XLFSTR(NDC,"-")
+12 IF $LENGTH(NDC)=12
SET NDC=$EXTRACT(NDC,2,12)
+13 WRITE !,"Querying Apelon site..."
+14 SET IN=NDC_"^N"
SET ZDATA=$$DI2RX^BSTSAPI(IN)
+15 SET RXNORM=$PIECE(ZDATA,U,1)
+16 IF RXNORM'=""
DO STORE(RXNORM)
WRITE !,RXNORM_" code stored"
+17 IF '$TEST
WRITE !,"Unable to map this NDC code"
End DoDot:1
+18 IF APSPNUM="NAME"
Begin DoDot:1
+19 NEW CNT,CT,RXCODE,DESC,DATA
+20 KILL ARR,^TMP($JOB)
+21 SET CT=0
+22 WRITE !,"Querying Apelon site..."
+23 SET IN=$PIECE(NAME," ",1)_"^F^1552^^^^P"
+24 SET OUT="^TMP(""APSPRX"",$J)"
+25 SET ZDATA=$$SEARCH^BSTSAPI(.OUT,.IN)
+26 IF ZDATA>0
Begin DoDot:2
+27 SET CNT=""
FOR
SET CNT=$ORDER(@OUT@(CNT))
IF CNT=""
QUIT
Begin DoDot:3
+28 ;S DATA=$G(@OUT@(CNT,"CON"))_U_$G(@OUT@(CNT,"PRE","TRM"))
+29 SET DATA=$GET(@OUT@(CNT,"PRE","TRM"))
+30 SET DESC=$GET(@OUT@(CNT,"PRE","TRM"))
+31 SET ^TMP($JOB,CNT,0)=DATA
+32 SET ^TMP($JOB,"B",DATA)=CNT
+33 SET CT=CT+1
End DoDot:3
+34 SET ^TMP($JOB,0)=U_U_CT_U_CT
+35 WRITE !!,"Enter ? to see the list of RxNorm Name Matches"
+36 WRITE !,"Enter ^ to quit the selection",!
+37 SET DIC="^TMP($J,"
SET DIC(0)="AEQ"
SET DIC("A")="Select RxNORM Item: "
+38 DO ^DIC
+39 SET RXNORM=Y
+40 SET RXCODE=$GET(^TMP("APSPRX",$JOB,$PIECE(RXNORM,U,1),"PRE","DSC"))
+41 IF RXCODE'=-1&(RXCODE'="")
DO STORE(RXCODE)
WRITE !,RXCODE_" code stored"
End DoDot:2
End DoDot:1
+42 WRITE !!,"Do you want to continue?"
SET %=2
DO YN^DICN
+43 IF %=1
GOTO ASK
+44 QUIT
STORE(RXNORM) ;store code
+1 NEW DA,DIE,DR,X,Y
+2 SET DA=IEN
+3 SET DIE="^PSDRUG("
+4 SET DR="9999999.27///^S X=RXNORM"
+5 DO ^DIE
+6 QUIT
