- 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
