ABSPOS9 ; IHS/FCS/DRS - NDC # lookup, formatting ;
;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
; Relies on the ^APSAMDF AWP-MED TRANSACTION file
; Several $$ routines called from lots of places.
;
Q
NDC11(N) ;EP - given N?11N
I '$$FINDNDC(N) Q ""
Q $$FMTNDC(N,5,4,2) ; must be 5-4-2?
NDC10(N) ;EP - given N?10N, find format and format it
N M,X,Y,Z
S M=0_N,X=$$FINDNDC(M,1) ; is it valid in 4-4-2 format?
I X Q $$FMTNDC(N,4,4,2)
S M=$E(N,1,5)_0_$E(N,6,10) ; is it valid in 5-3-2 format?
S X=$$FINDNDC(M,2)
I X Q $$FMTNDC(N,5,3,2)
S M=$E(N,1,9)_0_$E(N,10) ; is it valid in 5-4-1 format?
S X=$$FINDNDC(M,3)
I X Q $$FMTNDC(N,5,4,1)
; No, didn't find it anywhere
Q ""
FMTNDC(N,A,B,C) ; given N?1n.n and A-B-C format
I $D(A) Q $E(N,1,A)_"-"_$E(N,A+1,A+B)_"-"_$E(N,A+B+1,A+B+C)
MAKE11N(X) ;EP - given NDC code with "-", convert to ?11N
; it may involve putting an extra 0 in the right place
I X?5N1"-"4N1"-"2N ; it's okay as-is
E I X?4N1"-"4N1"-"2N S $P(X,"-",1)="0"_$P(X,"-",1)
E I X?5N1"-"3N1"-"2N S $P(X,"-",2)="0"_$P(X,"-",2)
E I X?5N1"-"4N1"-"1N S $P(X,"-",3)="0"_$P(X,"-",3)
Q $TR(X,"-")
NAME(X) ;EP - return drug name as stored in ^APSAMDF
N Y I X["-" S Y=$$MAKE11N(X)
E S Y=X
I Y'?11N Q "(can't figure out 11N format?)"
N Z S Z=$O(^APSAMDF("B",Y,0))
I Z Q $P($G(^APSAMDF(Z,2)),U)
; not in AWP-MED TRANSACTION; try the DRUG file
S Z=$O(^PSDRUG("ZNDC",$TR(X,"-",""),0))
I Z Q $P(^PSDRUG(Z,0),U)_" (from DRUG file)"
Q "("_X_" in neither AWP-MED TRANSACTION nor DRUG file)"
FINDNDC(N,F) ; return pointer into AWP MED-TRANSACTION
; F is optional - if F present, then it must match for this format
; returns null if not found
N X S X=$O(^APSAMDF("B",N,0)) I X="" Q ""
I '$D(F) Q X
I $P(^APSAMDF(X,2),U,3)'=F Q "" ; yes, but not in this format
Q X ; matches number and format, both
FORMTNDC(N) ;EP - given N?11N, lookup format and put "-" in right places
I N'?11N S N=$TR($J(N,11)," ","0") I N'?11N Q N
N X,F S X=$$FINDNDC(N) I 'X Q N
I X S F=$P($G(^APSAMDF(X,2)),U,3) I 'F Q N
; 4-4-2 format
I F=1,X?1"0"4N4N2N Q $$FMTNDC(N,4,4,2)
; 5-3-2 format
I F=2,X?5N1"0"3N2N Q:$$FMTNDC(N,5,3,2)
; 5-4-1 format
I F=3,X?5N4N1"0"1N Q $$FMTNDC(N,5,4,1)
; else 5-4-2 format?
Q $$FMTNDC(N,5,4,2)
Q
NDCTEST ;
W "Comprehensive test of valid NDC #s",!
S OUTPUT=0
S NDC=0 F I=1:1 S NDC=$O(^APSAMDF("B",NDC)) Q:'NDC D NDCTEST0
Q
NDCTEST0 ;
N X S X=$$FINDNDC(NDC) I 'X D Q
. D IMPOSS^ABSPOSUE("P","T",,,"NDCTEST0",$T(+0))
N F S F=$P(^APSAMDF(X,2),"^",3)
Q:F=4 Q:F=5
D NDCTEST1(NDC)
I $E(NDC,1)=0 W:OUTPUT "4-4-2 test..." D NDCTEST1($E(NDC,2,11))
I $E(NDC,6)=0 W:OUTPUT "5-3-2 test..." D NDCTEST1($E(NDC,1,5)_$E(NDC,7,11))
I $E(NDC,10)=0 W:OUTPUT "5-4-1 test..." D NDCTEST1($E(NDC,1,9)_$E(NDC,11))
Q
NDCTEST1(NDC) ; given NDC
N X,F
I $L(NDC)=11 D Q
.S X=$$FINDNDC(NDC)
.I X D
..N F S F=$P(^APSAMDF(X,2),"^",3)
..W:OUTPUT $$FMTNDC(NDC,5,4,2)," Format=",F,!
.E W NDC," Not found",!
W:OUTPUT "Test ",NDC,"..."
I $L(NDC)'=10 D Q
. D IMPOSS^ABSPOSUE("P","T","$L(NDC)'=10",NDC,"NDCTEST1",$T(+0))
N Y,Z
S X=$$FINDNDC(0_NDC,1) ; is it 4-4-2
S Y=$$FINDNDC($E(NDC,1,5)_0_$E(NDC,6,10),2) ; is it 5-3-2?
S Z=$$FINDNDC($E(NDC,1,9)_0_$E(NDC,10),3) ; is it 5-4-1?
I X&Y!(X&Z)!(Y&Z) W NDC," Ambiguity!",!
I 'X,'Y,'Z W NDC," Not found!",!
I X W:OUTPUT $$FMTNDC(NDC,4,4,2),!
I Y W:OUTPUT $$FMTNDC(NDC,5,3,2),!
I Z W:OUTPUT $$FMTNDC(NDC,5,4,1),!
Q
ABSPOS9 ; IHS/FCS/DRS - NDC # lookup, formatting ;
+1 ;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
+2 ; Relies on the ^APSAMDF AWP-MED TRANSACTION file
+3 ; Several $$ routines called from lots of places.
+4 ;
+5 QUIT
NDC11(N) ;EP - given N?11N
+1 IF '$$FINDNDC(N)
QUIT ""
+2 ; must be 5-4-2?
QUIT $$FMTNDC(N,5,4,2)
NDC10(N) ;EP - given N?10N, find format and format it
+1 NEW M,X,Y,Z
+2 ; is it valid in 4-4-2 format?
SET M=0_N
SET X=$$FINDNDC(M,1)
+3 IF X
QUIT $$FMTNDC(N,4,4,2)
+4 ; is it valid in 5-3-2 format?
SET M=$EXTRACT(N,1,5)_0_$EXTRACT(N,6,10)
+5 SET X=$$FINDNDC(M,2)
+6 IF X
QUIT $$FMTNDC(N,5,3,2)
+7 ; is it valid in 5-4-1 format?
SET M=$EXTRACT(N,1,9)_0_$EXTRACT(N,10)
+8 SET X=$$FINDNDC(M,3)
+9 IF X
QUIT $$FMTNDC(N,5,4,1)
+10 ; No, didn't find it anywhere
+11 QUIT ""
FMTNDC(N,A,B,C) ; given N?1n.n and A-B-C format
+1 IF $DATA(A)
QUIT $EXTRACT(N,1,A)_"-"_$EXTRACT(N,A+1,A+B)_"-"_$EXTRACT(N,A+B+1,A+B+C)
MAKE11N(X) ;EP - given NDC code with "-", convert to ?11N
+1 ; it may involve putting an extra 0 in the right place
+2 ; it's okay as-is
IF X?5N1"-"4N1"-"2N
+3 IF '$TEST
IF X?4N1"-"4N1"-"2N
SET $PIECE(X,"-",1)="0"_$PIECE(X,"-",1)
+4 IF '$TEST
IF X?5N1"-"3N1"-"2N
SET $PIECE(X,"-",2)="0"_$PIECE(X,"-",2)
+5 IF '$TEST
IF X?5N1"-"4N1"-"1N
SET $PIECE(X,"-",3)="0"_$PIECE(X,"-",3)
+6 QUIT $TRANSLATE(X,"-")
NAME(X) ;EP - return drug name as stored in ^APSAMDF
+1 NEW Y
IF X["-"
SET Y=$$MAKE11N(X)
+2 IF '$TEST
SET Y=X
+3 IF Y'?11N
QUIT "(can't figure out 11N format?)"
+4 NEW Z
SET Z=$ORDER(^APSAMDF("B",Y,0))
+5 IF Z
QUIT $PIECE($GET(^APSAMDF(Z,2)),U)
+6 ; not in AWP-MED TRANSACTION; try the DRUG file
+7 SET Z=$ORDER(^PSDRUG("ZNDC",$TRANSLATE(X,"-",""),0))
+8 IF Z
QUIT $PIECE(^PSDRUG(Z,0),U)_" (from DRUG file)"
+9 QUIT "("_X_" in neither AWP-MED TRANSACTION nor DRUG file)"
FINDNDC(N,F) ; return pointer into AWP MED-TRANSACTION
+1 ; F is optional - if F present, then it must match for this format
+2 ; returns null if not found
+3 NEW X
SET X=$ORDER(^APSAMDF("B",N,0))
IF X=""
QUIT ""
+4 IF '$DATA(F)
QUIT X
+5 ; yes, but not in this format
IF $PIECE(^APSAMDF(X,2),U,3)'=F
QUIT ""
+6 ; matches number and format, both
QUIT X
FORMTNDC(N) ;EP - given N?11N, lookup format and put "-" in right places
+1 IF N'?11N
SET N=$TRANSLATE($JUSTIFY(N,11)," ","0")
IF N'?11N
QUIT N
+2 NEW X,F
SET X=$$FINDNDC(N)
IF 'X
QUIT N
+3 IF X
SET F=$PIECE($GET(^APSAMDF(X,2)),U,3)
IF 'F
QUIT N
+4 ; 4-4-2 format
+5 IF F=1
IF X?1"0"4N4N2N
QUIT $$FMTNDC(N,4,4,2)
+6 ; 5-3-2 format
+7 IF F=2
IF X?5N1"0"3N2N
IF $$FMTNDC(N,5,3,2)
QUIT
+8 ; 5-4-1 format
+9 IF F=3
IF X?5N4N1"0"1N
QUIT $$FMTNDC(N,5,4,1)
+10 ; else 5-4-2 format?
+11 QUIT $$FMTNDC(N,5,4,2)
+12 QUIT
NDCTEST ;
+1 WRITE "Comprehensive test of valid NDC #s",!
+2 SET OUTPUT=0
+3 SET NDC=0
FOR I=1:1
SET NDC=$ORDER(^APSAMDF("B",NDC))
IF 'NDC
QUIT
DO NDCTEST0
+4 QUIT
NDCTEST0 ;
+1 NEW X
SET X=$$FINDNDC(NDC)
IF 'X
Begin DoDot:1
+2 DO IMPOSS^ABSPOSUE("P","T",,,"NDCTEST0",$TEXT(+0))
End DoDot:1
QUIT
+3 NEW F
SET F=$PIECE(^APSAMDF(X,2),"^",3)
+4 IF F=4
QUIT
IF F=5
QUIT
+5 DO NDCTEST1(NDC)
+6 IF $EXTRACT(NDC,1)=0
IF OUTPUT
WRITE "4-4-2 test..."
DO NDCTEST1($EXTRACT(NDC,2,11))
+7 IF $EXTRACT(NDC,6)=0
IF OUTPUT
WRITE "5-3-2 test..."
DO NDCTEST1($EXTRACT(NDC,1,5)_$EXTRACT(NDC,7,11))
+8 IF $EXTRACT(NDC,10)=0
IF OUTPUT
WRITE "5-4-1 test..."
DO NDCTEST1($EXTRACT(NDC,1,9)_$EXTRACT(NDC,11))
+9 QUIT
NDCTEST1(NDC) ; given NDC
+1 NEW X,F
+2 IF $LENGTH(NDC)=11
Begin DoDot:1
+3 SET X=$$FINDNDC(NDC)
+4 IF X
Begin DoDot:2
+5 NEW F
SET F=$PIECE(^APSAMDF(X,2),"^",3)
+6 IF OUTPUT
WRITE $$FMTNDC(NDC,5,4,2)," Format=",F,!
End DoDot:2
+7 IF '$TEST
WRITE NDC," Not found",!
End DoDot:1
QUIT
+8 IF OUTPUT
WRITE "Test ",NDC,"..."
+9 IF $LENGTH(NDC)'=10
Begin DoDot:1
+10 DO IMPOSS^ABSPOSUE("P","T","$L(NDC)'=10",NDC,"NDCTEST1",$TEXT(+0))
End DoDot:1
QUIT
+11 NEW Y,Z
+12 ; is it 4-4-2
SET X=$$FINDNDC(0_NDC,1)
+13 ; is it 5-3-2?
SET Y=$$FINDNDC($EXTRACT(NDC,1,5)_0_$EXTRACT(NDC,6,10),2)
+14 ; is it 5-4-1?
SET Z=$$FINDNDC($EXTRACT(NDC,1,9)_0_$EXTRACT(NDC,10),3)
+15 IF X&Y!(X&Z)!(Y&Z)
WRITE NDC," Ambiguity!",!
+16 IF 'X
IF 'Y
IF 'Z
WRITE NDC," Not found!",!
+17 IF X
IF OUTPUT
WRITE $$FMTNDC(NDC,4,4,2),!
+18 IF Y
IF OUTPUT
WRITE $$FMTNDC(NDC,5,3,2),!
+19 IF Z
IF OUTPUT
WRITE $$FMTNDC(NDC,5,4,1),!
+20 QUIT
