BPBSUPD ;IHS/CIA/PLS - Update Drug File from AWP data ;10-Aug-2005 21:57;SM
;;1.0;PHARMACY BARCODE SCAN;;August 10, 2005
;=================================================================
EN ;PEP - Called by the BPBS AWP SCAN BARCODE option
N DONE,APSPOP,TXT1,TXT2
I $$VERSION^XPDUTL("PSS")<1 D Q
.W !,"This option requires the Pharmacy Data Management Package!"
D:'$D(PSOPAR) ^PSOLSET
D INIT
F Q:$$LKUP(0)
;
D FINAL^PSOLSET
Q
;
LKUP(BC) ;EP
N IEN,DATA,DRUG,DIC
N X,FDA,PSSZ,PSSFLAG,AIEN,APRMPT,DA
W !
S PSSZ=1,PSSFLAG=0
S IEN=$$GETIENA(50,"",-1,"","","QEALMNTV","",1)
Q:IEN<1 1
;Q:'IEN 1
I IEN D
.S AIEN=$$GETNDC() Q:AIEN<0
.I 'AIEN D
..S APRMPT="Would you like to manually update drug information"
..S APRMPT(1)="A match cannot be found."
..I $$DIRYN(.APRMPT,"Yes") D
...D EDITDRG(1,IEN)
.E D
..; STUFF FIELDS
..D DISPLAY(AIEN)
..Q:'$$DIRYN("Do you want to update the Drug File","Yes")
..D GETDATA(AIEN,.DATA),SETDATA(IEN,.DATA,.FDA)
..D STORE(IEN,.FDA)
..D EDITDRG(0,IEN)
.S IEN=0
Q 0
;
DISPLAY(IEN) ;EP
W !,"You have selected to edit the settings for the following drug:"
W !,?5,"Name : ",$$GET1^DIQ(9009037,IEN,201)
W !,?5,"NDC : ",$$GET1^DIQ(9009037,IEN,.01) ;,?25,"Pattern: ",$$GET1^DIQ(9009037,IEN,203)
W !,?5,"Manuf: ",$$GET1^DIQ(9009037,IEN,205)
;W !,?7,"AWP Effective Date: ",$$FMTE^XLFDT($$GET1^DIQ(9009037,IEN,.02,"I"),"5Z")
W !,?5,"Dispense Units per Order: "_$$GET1^DIQ(9009037,IEN,103)
W !
Q
; Find Drug File entry by NDC
FINDDRG(NDC) ;EP
N ERR
Q $$FIND1^DIC(50,,,NDC,"ZNDC",,"ERR")
; Get data from AWP File
GETDATA(IEN,DATA) ;EP
N DRUG,ERR
S DATA(.01)=$$GET1^DIQ(9009037,IEN,.01) ;NDC-UPC-HRI
S DATA(.02)=$$GET1^DIQ(9009037,IEN,.02,"I") ;EFFECTIVE DATE
S DATA(.03)=$$GET1^DIQ(9009037,IEN,.03) ;PER DISP UNIT
S DATA(.04)=$$GET1^DIQ(9009037,IEN,.04) ;PER ORDER UNIT
S DATA(101)=$$GET1^DIQ(9009037,IEN,101) ;PACKAGE SIZE
S DATA(102)=$$GET1^DIQ(9009037,IEN,102) ;PACKAGE QUANTITY
S DATA(103)=$$GET1^DIQ(9009037,IEN,103) ;DISP UNITS PER ORDER
;S DATA(104)=$$GET1^DIQ(9009037,IEN,104) ;
S DATA(201)=$$UP^XLFSTR($$TRIM^XLFSTR($$GET1^DIQ(9009037,IEN,201),"R")) ;DRUG NAME
S DATA(205)=$$GET1^DIQ(9009037,IEN,205) ;MANUFACTURER
S DATA(206)=$$GET1^DIQ(9009037,IEN,206) ;GENERIC PRODUCT ID
S DATA(403)=$$GET1^DIQ(9009037,IEN,403) ;AAC PER DISPENSE UNIT
S DATA(404)=$$GET1^DIQ(9009037,IEN,404) ;AAC PER ORDER UNIT
Q
; Set data into FDA Array
SETDATA(DRUG,DATA,FDA) ;EP
N FN,SYN,NDC
S SYN=$$HASSYN(DRUG,DATA(201))
S FN=50,DRUG=DRUG_","
S NDC=DATA(.01)
;S FDA(FN,DRUG,12)="" ; Order Unit
;S FDA(FN,DRUG,3)="" ; DEA
;S FDA(FN,DRUG,14.5)=DATA(101) ; WILL NOT BE USED
S FDA(FN,DRUG,31)=$E(NDC,1,5)_"-"_$E(NDC,6,9)_"-"_$E(NDC,10,11)
;S FDA(FN,DRUG,15)=DATA(101)*DATA(102)
S FDA(FN,DRUG,15)=DATA(103)
S:DATA(.04)'="" FDA(FN,DRUG,9999999.31)=+DATA(.04)
S:DATA(.03)'="" FDA(FN,DRUG,9999999.32)=+DATA(.03)
S:DATA(.02) FDA(FN,DRUG,9999999.33)=DATA(.02)
S:DATA(403)'="" FDA(FN,DRUG,16)=DATA(403)
S:DATA(404)'="" FDA(FN,DRUG,13)=DATA(404)
S:'SYN FDA(FN+.1,"?+1,"_DRUG,.01)=DATA(201) ; Drug Name
S FDA(FN+.1,$S(SYN:SYN,1:"?+1")_","_DRUG,1)=0 ; Trade Name
S FDA(FN+.1,$S(SYN:SYN,1:"?+1")_","_DRUG,2)=DATA(.01) ; NDC-UPC-HRI
S:DATA(205)'="" FDA(FN+.1,$S(SYN:SYN,1:"?+1")_","_DRUG,405)=DATA(205)
Q
;
; Commit updates to File 50.
STORE(DRUG,FDA,NEW) ;EP
N MSG
W !,?5,"Applying updates..."
S NEW=$G(NEW,1)
I NEW D
.D UPDATE^DIE(,"FDA",,"MSG")
E D
.D FILE^DIE("K","FDA","MSG")
I $D(MSG) D
.W !,"The following error occurred:"
.W !,$G(MSG("DIERR",1,"TEXT",1))
E W !,?5,"Updates are complete..."
K FDA
Q
; Prompt for entry from file (Calls MIX^DIC1)
; APSFILE = File #
; APSPMPT = Prompt
; APSDFLD = Field whose value is to be used for default value
; Set to -1 for no default value
; D = x-ref (C^D)
; APSSCRN = DIC("S") SCREEN LOGIC
; APSDIC0 = Parameters for DIC(0)
; APSLYFLD = List of forced identifier fields (DR) to override the defaulted fields.
GETIEN(APSFILE,APSPMPT,APSDFLD,D,APSSCRN,APSDIC0,APSLYFLD) ;EP
N DIC,APSD,Y,DA
S D=$G(D,"B")
S:'$L(D) D="B"
S DIC(0)=$G(APSDIC0,"AE")
S APSDFLD=$G(APSDFLD,.01)
S APSD=""
S DIC("S")=$G(APSSCRN)
S:APSDFLD>0 APSD=$$GET1^DIQ(APSFILE,$$FIND1^DIC(APSFILE,,," ",.D,DIC("S")),APSDFLD)
S DIC=APSFILE
S DIC("A")=$G(APSPMPT),DIC("B")=APSD
I $L(D,U)>1,DIC(0)'["M" S DIC(0)=DIC(0)_"M"
I DIC(0)["L" S DIC("DR")=$G(APSLYFLD) ; Set force identifiers to inputted list
D MIX^DIC1
Q $S($D(DTOUT)!($D(DUOUT)):-1,+Y>0:+Y,1:0)
;
; Prompt for entry from file (calls ^DIC)
; APSFILE = File #
; APSPMPT = Prompt
; APSDFLD = Field whose value is to be used for default value
; Set to -1 for no default value
; D = x-ref (C^D)
; APSSCRN = DIC("S") SCREEN LOGIC
; APSDIC0 = Parameters for DIC(0)
; APSLYFLD = List of forced identifier fields (DR) to override the defaulted fields.
; EVRYREC = If defined, will set DIC("T")
GETIENA(APSFILE,APSPMPT,APSDFLD,D,APSSCRN,APSDIC0,APSLYFLD,EVRYREC) ;EP
N DIC,APSD,Y,DA,DUOUT,DTOUT
S DIC(0)=$G(APSDIC0,"AE")
S APSDFLD=$G(APSDFLD,.01)
S APSD=""
S:$L($G(APSSCRN)) DIC("S")=$G(APSSCRN)
S:APSDFLD>0 APSD=$$GET1^DIQ(APSFILE,$$FIND1^DIC(APSFILE,,," ",.D,DIC("S")),APSDFLD)
S DIC=APSFILE
S:$G(EVRYREC) DIC("T")=""
S DIC("A")=$G(APSPMPT),DIC("B")=APSD
I DIC(0)["L" S DIC("DR")=$G(APSLYFLD) ; Set force identifiers to inputted list
D ^DIC
Q $S($D(DTOUT)!($D(DUOUT)):-1,+Y>0:+Y,1:0)
;
GETNDC() ;EP
N IEN,UPC,ERR,NDC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,Y
S DIR("A")="Scan or enter UPC/NDC Value"
S DIR("A",1)="Format: NDC Value(5-4-2 format, no dashes)"
S DIR("A",2)=" UPC Value(Full barcode number)"
S DIR("?")="The value must be between 11 and 14 numbers and not contain a '-'."
S DIR(0)="FO^11:14^K:X'?11N.N X"
D ^DIR
Q:$D(DTOUT)!($D(DUOUT)) -1
S UPC=Y
Q:UPC="" 0
I $L(UPC)>11 D ; A UPC code was scanned.
.S NDC=$E(UPC,$L(UPC)-10,$L(UPC)-1)
.I $E(NDC,1) S NDC=$E(NDC,1,5)_"0"_$E(NDC,6,10)
.E S NDC="0"_NDC
E D ; A NDC was manually entered
.S NDC=$E(UPC,1,11)
S IEN=$$FIND1^DIC(9009037,,,NDC,,,"ERR")
Q IEN
;
FMTNDC(NDC) ;EP
;Q:NDC["-" NDC
I $E(NDC,1) S NDC=$E(NDC,1,5)_"-0"_$E(NDC,6,8)_"-"_$E(NDC,9,10)
E S NDC="0"_$E(NDC,1,4)_"-"_$E(NDC,5,8)_"-"_$E(NDC,9,10)
Q NDC
; DIR call for Y/N response
DIRYN(APSPMT,APSDFL,APSHLP,APSPOP) ;EP
N Y
S Y=$$DIR("YO",.APSPMT,.APSDFL,.APSHLP,.APSPOP)
Q Y
;
; Parameterized DIR call
DIR(APSDTP,APSPMT,APSDFL,APSHLP,APSPOP,APSSCRN) ;EP
N DIR,DTOUT,DUOUT,Y
S DIR(0)=APSDTP
S:$L($G(APSDFL)) DIR("B")=$G(APSDFL)
I '$G(APSPMT) M DIR("A")=APSPMT
I '$G(APSHLP) M DIR("?")=APSHLP
S DIR("S")=$G(APSSCRN,"")
I $G(APSKDIRB) K DIR("B")
D ^DIR
S:$D(DUOUT)!$D(DTOUT) APSPOP=1
Q Y
; Pause for user input
DIRZ(APSPMT) ;EP
N X
S X=$$DIR("E",.APSPMT,,,.APSPOP)
Q
; Return AWP Drug Name
GAWPDNM(DRGIEN) ;EP
Q $$GET1^DIQ(9009037,DRGIEN,201)
; Return Synonym IEN
HASSYN(DRGIEN,SYN) ;EP
N RES,LP
S RES=0
I DRGIEN,$L(SYN) D
.S LP=0 F S LP=$O(^PSDRUG(DRGIEN,1,LP)) Q:'LP D Q:RES
..I $P(^PSDRUG(DRGIEN,1,LP,0),U)=SYN S RES=LP
Q RES
; Edit Drug File entry
EDITDRG(MANUAL,DRUG) ;EP
S MANUAL=$G(MANUAL,1)
D PSSMAN^BPBSUPD1(MANUAL,DRUG)
Q
; Setup
INIT ;EP
S TXT1="Unable to locate drug for NDC"
S TXT2="Please manually enter the NDC number in 5-4-2 format(NO DASHES)."
S TXT3="Do you wish to manually enter drug information"
Q
;
T1 ;EP
N PRMPT
S PRMPT="Would you like to manually update the Drug File"
S PRMPT(1)="A match cannot be found!"
W $$DIRYN(.PRMPT,"Yes")
Q
BPBSUPD ;IHS/CIA/PLS - Update Drug File from AWP data ;10-Aug-2005 21:57;SM
+1 ;;1.0;PHARMACY BARCODE SCAN;;August 10, 2005
+2 ;=================================================================
EN ;PEP - Called by the BPBS AWP SCAN BARCODE option
+1 NEW DONE,APSPOP,TXT1,TXT2
+2 IF $$VERSION^XPDUTL("PSS")<1
Begin DoDot:1
+3 WRITE !,"This option requires the Pharmacy Data Management Package!"
End DoDot:1
QUIT
+4 IF '$DATA(PSOPAR)
DO ^PSOLSET
+5 DO INIT
+6 FOR
IF $$LKUP(0)
QUIT
+7 ;
+8 DO FINAL^PSOLSET
+9 QUIT
+10 ;
LKUP(BC) ;EP
+1 NEW IEN,DATA,DRUG,DIC
+2 NEW X,FDA,PSSZ,PSSFLAG,AIEN,APRMPT,DA
+3 WRITE !
+4 SET PSSZ=1
SET PSSFLAG=0
+5 SET IEN=$$GETIENA(50,"",-1,"","","QEALMNTV","",1)
+6 IF IEN<1
QUIT 1
+7 ;Q:'IEN 1
+8 IF IEN
Begin DoDot:1
+9 SET AIEN=$$GETNDC()
IF AIEN<0
QUIT
+10 IF 'AIEN
Begin DoDot:2
+11 SET APRMPT="Would you like to manually update drug information"
+12 SET APRMPT(1)="A match cannot be found."
+13 IF $$DIRYN(.APRMPT,"Yes")
Begin DoDot:3
+14 DO EDITDRG(1,IEN)
End DoDot:3
End DoDot:2
+15 IF '$TEST
Begin DoDot:2
+16 ; STUFF FIELDS
+17 DO DISPLAY(AIEN)
+18 IF '$$DIRYN("Do you want to update the Drug File","Yes")
QUIT
+19 DO GETDATA(AIEN,.DATA)
DO SETDATA(IEN,.DATA,.FDA)
+20 DO STORE(IEN,.FDA)
+21 DO EDITDRG(0,IEN)
End DoDot:2
+22 SET IEN=0
End DoDot:1
+23 QUIT 0
+24 ;
DISPLAY(IEN) ;EP
+1 WRITE !,"You have selected to edit the settings for the following drug:"
+2 WRITE !,?5,"Name : ",$$GET1^DIQ(9009037,IEN,201)
+3 ;,?25,"Pattern: ",$$GET1^DIQ(9009037,IEN,203)
WRITE !,?5,"NDC : ",$$GET1^DIQ(9009037,IEN,.01)
+4 WRITE !,?5,"Manuf: ",$$GET1^DIQ(9009037,IEN,205)
+5 ;W !,?7,"AWP Effective Date: ",$$FMTE^XLFDT($$GET1^DIQ(9009037,IEN,.02,"I"),"5Z")
+6 WRITE !,?5,"Dispense Units per Order: "_$$GET1^DIQ(9009037,IEN,103)
+7 WRITE !
+8 QUIT
+9 ; Find Drug File entry by NDC
FINDDRG(NDC) ;EP
+1 NEW ERR
+2 QUIT $$FIND1^DIC(50,,,NDC,"ZNDC",,"ERR")
+3 ; Get data from AWP File
GETDATA(IEN,DATA) ;EP
+1 NEW DRUG,ERR
+2 ;NDC-UPC-HRI
SET DATA(.01)=$$GET1^DIQ(9009037,IEN,.01)
+3 ;EFFECTIVE DATE
SET DATA(.02)=$$GET1^DIQ(9009037,IEN,.02,"I")
+4 ;PER DISP UNIT
SET DATA(.03)=$$GET1^DIQ(9009037,IEN,.03)
+5 ;PER ORDER UNIT
SET DATA(.04)=$$GET1^DIQ(9009037,IEN,.04)
+6 ;PACKAGE SIZE
SET DATA(101)=$$GET1^DIQ(9009037,IEN,101)
+7 ;PACKAGE QUANTITY
SET DATA(102)=$$GET1^DIQ(9009037,IEN,102)
+8 ;DISP UNITS PER ORDER
SET DATA(103)=$$GET1^DIQ(9009037,IEN,103)
+9 ;S DATA(104)=$$GET1^DIQ(9009037,IEN,104) ;
+10 ;DRUG NAME
SET DATA(201)=$$UP^XLFSTR($$TRIM^XLFSTR($$GET1^DIQ(9009037,IEN,201),"R"))
+11 ;MANUFACTURER
SET DATA(205)=$$GET1^DIQ(9009037,IEN,205)
+12 ;GENERIC PRODUCT ID
SET DATA(206)=$$GET1^DIQ(9009037,IEN,206)
+13 ;AAC PER DISPENSE UNIT
SET DATA(403)=$$GET1^DIQ(9009037,IEN,403)
+14 ;AAC PER ORDER UNIT
SET DATA(404)=$$GET1^DIQ(9009037,IEN,404)
+15 QUIT
+16 ; Set data into FDA Array
SETDATA(DRUG,DATA,FDA) ;EP
+1 NEW FN,SYN,NDC
+2 SET SYN=$$HASSYN(DRUG,DATA(201))
+3 SET FN=50
SET DRUG=DRUG_","
+4 SET NDC=DATA(.01)
+5 ;S FDA(FN,DRUG,12)="" ; Order Unit
+6 ;S FDA(FN,DRUG,3)="" ; DEA
+7 ;S FDA(FN,DRUG,14.5)=DATA(101) ; WILL NOT BE USED
+8 SET FDA(FN,DRUG,31)=$EXTRACT(NDC,1,5)_"-"_$EXTRACT(NDC,6,9)_"-"_$EXTRACT(NDC,10,11)
+9 ;S FDA(FN,DRUG,15)=DATA(101)*DATA(102)
+10 SET FDA(FN,DRUG,15)=DATA(103)
+11 IF DATA(.04)'=""
SET FDA(FN,DRUG,9999999.31)=+DATA(.04)
+12 IF DATA(.03)'=""
SET FDA(FN,DRUG,9999999.32)=+DATA(.03)
+13 IF DATA(.02)
SET FDA(FN,DRUG,9999999.33)=DATA(.02)
+14 IF DATA(403)'=""
SET FDA(FN,DRUG,16)=DATA(403)
+15 IF DATA(404)'=""
SET FDA(FN,DRUG,13)=DATA(404)
+16 ; Drug Name
IF 'SYN
SET FDA(FN+.1,"?+1,"_DRUG,.01)=DATA(201)
+17 ; Trade Name
SET FDA(FN+.1,$SELECT(SYN:SYN,1:"?+1")_","_DRUG,1)=0
+18 ; NDC-UPC-HRI
SET FDA(FN+.1,$SELECT(SYN:SYN,1:"?+1")_","_DRUG,2)=DATA(.01)
+19 IF DATA(205)'=""
SET FDA(FN+.1,$SELECT(SYN:SYN,1:"?+1")_","_DRUG,405)=DATA(205)
+20 QUIT
+21 ;
+22 ; Commit updates to File 50.
STORE(DRUG,FDA,NEW) ;EP
+1 NEW MSG
+2 WRITE !,?5,"Applying updates..."
+3 SET NEW=$GET(NEW,1)
+4 IF NEW
Begin DoDot:1
+5 DO UPDATE^DIE(,"FDA",,"MSG")
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 DO FILE^DIE("K","FDA","MSG")
End DoDot:1
+8 IF $DATA(MSG)
Begin DoDot:1
+9 WRITE !,"The following error occurred:"
+10 WRITE !,$GET(MSG("DIERR",1,"TEXT",1))
End DoDot:1
+11 IF '$TEST
WRITE !,?5,"Updates are complete..."
+12 KILL FDA
+13 QUIT
+14 ; Prompt for entry from file (Calls MIX^DIC1)
+15 ; APSFILE = File #
+16 ; APSPMPT = Prompt
+17 ; APSDFLD = Field whose value is to be used for default value
+18 ; Set to -1 for no default value
+19 ; D = x-ref (C^D)
+20 ; APSSCRN = DIC("S") SCREEN LOGIC
+21 ; APSDIC0 = Parameters for DIC(0)
+22 ; APSLYFLD = List of forced identifier fields (DR) to override the defaulted fields.
GETIEN(APSFILE,APSPMPT,APSDFLD,D,APSSCRN,APSDIC0,APSLYFLD) ;EP
+1 NEW DIC,APSD,Y,DA
+2 SET D=$GET(D,"B")
+3 IF '$LENGTH(D)
SET D="B"
+4 SET DIC(0)=$GET(APSDIC0,"AE")
+5 SET APSDFLD=$GET(APSDFLD,.01)
+6 SET APSD=""
+7 SET DIC("S")=$GET(APSSCRN)
+8 IF APSDFLD>0
SET APSD=$$GET1^DIQ(APSFILE,$$FIND1^DIC(APSFILE,,," ",.D,DIC("S")),APSDFLD)
+9 SET DIC=APSFILE
+10 SET DIC("A")=$GET(APSPMPT)
SET DIC("B")=APSD
+11 IF $LENGTH(D,U)>1
IF DIC(0)'["M"
SET DIC(0)=DIC(0)_"M"
+12 ; Set force identifiers to inputted list
IF DIC(0)["L"
SET DIC("DR")=$GET(APSLYFLD)
+13 DO MIX^DIC1
+14 QUIT $SELECT($DATA(DTOUT)!($DATA(DUOUT)):-1,+Y>0:+Y,1:0)
+15 ;
+16 ; Prompt for entry from file (calls ^DIC)
+17 ; APSFILE = File #
+18 ; APSPMPT = Prompt
+19 ; APSDFLD = Field whose value is to be used for default value
+20 ; Set to -1 for no default value
+21 ; D = x-ref (C^D)
+22 ; APSSCRN = DIC("S") SCREEN LOGIC
+23 ; APSDIC0 = Parameters for DIC(0)
+24 ; APSLYFLD = List of forced identifier fields (DR) to override the defaulted fields.
+25 ; EVRYREC = If defined, will set DIC("T")
GETIENA(APSFILE,APSPMPT,APSDFLD,D,APSSCRN,APSDIC0,APSLYFLD,EVRYREC) ;EP
+1 NEW DIC,APSD,Y,DA,DUOUT,DTOUT
+2 SET DIC(0)=$GET(APSDIC0,"AE")
+3 SET APSDFLD=$GET(APSDFLD,.01)
+4 SET APSD=""
+5 IF $LENGTH($GET(APSSCRN))
SET DIC("S")=$GET(APSSCRN)
+6 IF APSDFLD>0
SET APSD=$$GET1^DIQ(APSFILE,$$FIND1^DIC(APSFILE,,," ",.D,DIC("S")),APSDFLD)
+7 SET DIC=APSFILE
+8 IF $GET(EVRYREC)
SET DIC("T")=""
+9 SET DIC("A")=$GET(APSPMPT)
SET DIC("B")=APSD
+10 ; Set force identifiers to inputted list
IF DIC(0)["L"
SET DIC("DR")=$GET(APSLYFLD)
+11 DO ^DIC
+12 QUIT $SELECT($DATA(DTOUT)!($DATA(DUOUT)):-1,+Y>0:+Y,1:0)
+13 ;
GETNDC() ;EP
+1 NEW IEN,UPC,ERR,NDC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,Y
+2 SET DIR("A")="Scan or enter UPC/NDC Value"
+3 SET DIR("A",1)="Format: NDC Value(5-4-2 format, no dashes)"
+4 SET DIR("A",2)=" UPC Value(Full barcode number)"
+5 SET DIR("?")="The value must be between 11 and 14 numbers and not contain a '-'."
+6 SET DIR(0)="FO^11:14^K:X'?11N.N X"
+7 DO ^DIR
+8 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT -1
+9 SET UPC=Y
+10 IF UPC=""
QUIT 0
+11 ; A UPC code was scanned.
IF $LENGTH(UPC)>11
Begin DoDot:1
+12 SET NDC=$EXTRACT(UPC,$LENGTH(UPC)-10,$LENGTH(UPC)-1)
+13 IF $EXTRACT(NDC,1)
SET NDC=$EXTRACT(NDC,1,5)_"0"_$EXTRACT(NDC,6,10)
+14 IF '$TEST
SET NDC="0"_NDC
End DoDot:1
+15 ; A NDC was manually entered
IF '$TEST
Begin DoDot:1
+16 SET NDC=$EXTRACT(UPC,1,11)
End DoDot:1
+17 SET IEN=$$FIND1^DIC(9009037,,,NDC,,,"ERR")
+18 QUIT IEN
+19 ;
FMTNDC(NDC) ;EP
+1 ;Q:NDC["-" NDC
+2 IF $EXTRACT(NDC,1)
SET NDC=$EXTRACT(NDC,1,5)_"-0"_$EXTRACT(NDC,6,8)_"-"_$EXTRACT(NDC,9,10)
+3 IF '$TEST
SET NDC="0"_$EXTRACT(NDC,1,4)_"-"_$EXTRACT(NDC,5,8)_"-"_$EXTRACT(NDC,9,10)
+4 QUIT NDC
+5 ; DIR call for Y/N response
DIRYN(APSPMT,APSDFL,APSHLP,APSPOP) ;EP
+1 NEW Y
+2 SET Y=$$DIR("YO",.APSPMT,.APSDFL,.APSHLP,.APSPOP)
+3 QUIT Y
+4 ;
+5 ; Parameterized DIR call
DIR(APSDTP,APSPMT,APSDFL,APSHLP,APSPOP,APSSCRN) ;EP
+1 NEW DIR,DTOUT,DUOUT,Y
+2 SET DIR(0)=APSDTP
+3 IF $LENGTH($GET(APSDFL))
SET DIR("B")=$GET(APSDFL)
+4 IF '$GET(APSPMT)
MERGE DIR("A")=APSPMT
+5 IF '$GET(APSHLP)
MERGE DIR("?")=APSHLP
+6 SET DIR("S")=$GET(APSSCRN,"")
+7 IF $GET(APSKDIRB)
KILL DIR("B")
+8 DO ^DIR
+9 IF $DATA(DUOUT)!$DATA(DTOUT)
SET APSPOP=1
+10 QUIT Y
+11 ; Pause for user input
DIRZ(APSPMT) ;EP
+1 NEW X
+2 SET X=$$DIR("E",.APSPMT,,,.APSPOP)
+3 QUIT
+4 ; Return AWP Drug Name
GAWPDNM(DRGIEN) ;EP
+1 QUIT $$GET1^DIQ(9009037,DRGIEN,201)
+2 ; Return Synonym IEN
HASSYN(DRGIEN,SYN) ;EP
+1 NEW RES,LP
+2 SET RES=0
+3 IF DRGIEN
IF $LENGTH(SYN)
Begin DoDot:1
+4 SET LP=0
FOR
SET LP=$ORDER(^PSDRUG(DRGIEN,1,LP))
IF 'LP
QUIT
Begin DoDot:2
+5 IF $PIECE(^PSDRUG(DRGIEN,1,LP,0),U)=SYN
SET RES=LP
End DoDot:2
IF RES
QUIT
End DoDot:1
+6 QUIT RES
+7 ; Edit Drug File entry
EDITDRG(MANUAL,DRUG) ;EP
+1 SET MANUAL=$GET(MANUAL,1)
+2 DO PSSMAN^BPBSUPD1(MANUAL,DRUG)
+3 QUIT
+4 ; Setup
INIT ;EP
+1 SET TXT1="Unable to locate drug for NDC"
+2 SET TXT2="Please manually enter the NDC number in 5-4-2 format(NO DASHES)."
+3 SET TXT3="Do you wish to manually enter drug information"
+4 QUIT
+5 ;
T1 ;EP
+1 NEW PRMPT
+2 SET PRMPT="Would you like to manually update the Drug File"
+3 SET PRMPT(1)="A match cannot be found!"
+4 WRITE $$DIRYN(.PRMPT,"Yes")
+5 QUIT
