BINDC1 ;IHS/CMI/MWR - EDIT NDC NUMBERS.; MAY 10, 2010
;;8.5;IMMUNIZATION;**9**;OCT 01,2014
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; EDIT NDC NUMBER FIELDS.
;
;
;----------
INIT ;EP
;---> Initialize variables and list array.
;
S VALMSG="Enter ?? for more actions."
S VALM("TITLE")=$$LMVER^BILOGO
;
;---> Build Listmanager array.
K ^TMP("BINDC",$J),BINDC,BITMP
N BIENT,BILINE,BITMP S BIENT=0,BILINE=0
;---> BICOLL=Order of Listing (see linelabel CHGORDR below.
S:'$G(BICOLL) BICOLL=1
;---> Exclude inactive NDCs unless BIINACT=1. vvv83
S:'$G(BIINACT) BIINACT=0
;
N BIIEN S BIIEN=0
F S BIIEN=$O(^BINDC(BIIEN)) Q:'BIIEN D
.I '$D(^BINDC(BIIEN,0)) K ^BINDC(BIIEN) Q
.N BINDC,BIVACP,BIVNAM,BICVX,BIMAN,BIPROD,BIACT,W,X,Y,Z
.S Y=^BINDC(BIIEN,0),BINDC=$P(Y,U),BIVACP=+$P(Y,U,2)
.S BIVNAM=$$VNAME^BIUTL2(BIVACP)
.S BICVX=$$CODE^BIUTL2(BIVACP,6) S:BICVX="" BICVX=999
.S BIPROD=$E($P(Y,U,4),1,12) S:BIPROD="" BIPROD="Not Recorded"
.S BIMAN=+$P(Y,U,3),BIMAN=$$MNAME^BIUTL2(BIMAN)
.S BIACT=+$P(Y,U,6) ;1=inactive
.;---> Quit if excluding Inactive NDCs.
.Q:('BIINACT&BIACT=1)
.;---> If no Exp Date, set Exp Date=last in list.
.;Future, if Exp Date: S BIEXP=+$P(Y,U,?) S:'BIEXP BIEXP=9999999
.D
..I BICOLL=2 S W=BIVNAM,X=BINDC,Y=BIPROD,Z=BIMAN Q
..S W=BINDC,X=BIVNAM,Y=BIPROD,Z=BIMAN Q
..;---> Other possible orders:
..;I BICOLL=3 S W=BINDC,X=BIVNAM,Y=BIEXP,Z=BICVX Q
..;I BICOLL=4 S W=BIVNAM,X=BICVX,Y=BIEXP,Z=BINDC Q
.S BITMP(BIACT,W,X,Y,Z,BIIEN)=BIIEN
;
N N S N="" F S N=$O(BITMP(N)) Q:(N="") D
.;---> Place a linefeed between Active and Inactive.
.I N D WRITE(.BILINE,,,BIENT)
.;
.N M S M="" F S M=$O(BITMP(N,M)) Q:(M="") D
..N L S L="" F S L=$O(BITMP(N,M,L)) Q:(L="") D
...N K S K="" F S K=$O(BITMP(N,M,L,K)) Q:(K="") D
....N J S J="" F S J=$O(BITMP(N,M,L,K,J)) Q:(J="") D
.....N P S P="" F S P=$O(BITMP(N,M,L,K,J,P)) Q:(P="") D
......D LINE(BITMP(N,M,L,K,J,P),.BILINE,.BIENT)
;
;---> Finish up Listmanager List Count.
S VALMCNT=BILINE
I VALMCNT>12 D
.;
.;---> Display number of NDCs in list.
.N Y S Y=VALMCNT S:$G(BIINACT) Y=Y-1
.S VALMSG=Y_" NDCs: Scroll down to view more, or type ??."
Q
;
;
;----------
LINE(BIIEN,BILINE,BIENT) ;EP
;---> Gather data for each NDC and write to ^TMP.
;---> Parameters:
; 1 - BIIEN (req) IEN of NDC.
; 2 - BILINE (ret) Last line# written.
; 3 - BIENT (opt) Entry Number for LM selection in VALMY
;
N BI0,X,Y
S BI0=^BINDC(BIIEN,0)
;
;---> Set Item# and build Item# array=IEN of Vaccine.
S BIENT=BIENT+1,BINDC(BIENT)=BIIEN
;
;---> Item#.
S X=" "_$S(BIENT<10:" "_BIENT,1:BIENT)
;
;---> NDC Code.
S X=X_" "_$P(BI0,U)
S X=$$PAD^BIUTL5(X,21,".")
;
;---> Vaccine.
N BIVACP S BIVACP=+$P(BI0,U,2)
D
.I 'BIVACP S X=X_"UNKNOWN" Q
.S X=X_$$VNAME^BIUTL2(BIVACP)
S X=$$PAD^BIUTL5(X,32,".")
;
;---> CVX.
N BICVX S BICVX=$$CODE^BIUTL2(BIVACP,6) S:('BICVX) BICVX="UNK"
S:($L(BICVX))=1 BICVX=".."_BICVX S:($L(BICVX))=2 BICVX="."_BICVX
S X=X_BICVX
S X=$$PAD^BIUTL5(X,38,".")
;
;---> Product.
N BIPROD S BIPROD=$E($P(BI0,U,4),1,12) S:BIPROD="" BIPROD="Not Recorded"
S X=X_BIPROD
S X=$$PAD^BIUTL5(X,53,".")
;
;---> Manufacturer.
N BIMAN D
.S BIMAN=+$P(BI0,U,3)
.I 'BIMAN S BIMAN="Not Recorded" Q
.S BIMAN=$E($$MNAME^BIUTL2(BIMAN),1,16)
S X=X_BIMAN
S X=$$PAD^BIUTL5(X,71,".")
;
;---> Active/Inactive Status.
S X=X_$S($P(BI0,U,6)=1:"Inactive",1:"Active")
;
;---> Set this Vaccine display row and index in ^TMP.
D WRITE(.BILINE,X,,BIENT)
Q
;
;
;----------
WRITE(BILINE,BIVAL,BIBLNK,BIENT) ;EP
;---> Write lines to ^TMP (see documentation in ^BIW).
;---> Parameters:
; 1 - BILINE (ret) Last line# written.
; 2 - BIVAL (opt) Value/text of line (Null=blank line).
; 3 - BIBLNK (opt) Number of blank lines to add after line sent.
; 4 - BIENT (opt) Entry Number for LM selection in VALMY
;
Q:'$D(BILINE)
D WL^BIW(.BILINE,"BINDC",$G(BIVAL),$G(BIBLNK),$G(BIENT))
Q
;
;
;----------
EDITNDC(BINEW) ;EP
;---> Add or Edit an NDC Number.
;---> Parameters:
; 2 - BINEW (opt) 1=new NDC number being added; 0/""=edit.
;
N BIDA
;---> If BINEW, add a new NDC Number and quit.
;I $G(BINEW) D EDITSCR(,1) D RESET Q
I $G(BINEW) D Q
.D ADDFM
.D FULL^VALM1,RESET
;
;---> This is an Edit, so continue.
;---> Call the Listmanager Generic Selector of items displayed.
N VALMY
D EN^VALM2(XQORNOD(0),"OS")
;
;---> Check that a Listman Item was passed.
I '$D(VALMY) D ERRCD^BIUTL2(406,,1) D RESET Q
;---> Now set Y=Item# selected from the list.
N Y S Y=$O(VALMY(0))
I '$G(Y) D ERRCD^BIUTL2(406,,1) D RESET Q
I $G(BINDC(Y))="" D ERRCD^BIUTL2(511,,1) D RESET Q
N BIDA S BIDA=+BINDC(Y)
I $G(^BINDC(BIDA,0))="" D ERRCD^BIUTL2(515,,1) D RESET Q
;---> Use next line and called code if you want to use Screenman.
;D EDITSCR(+BINDC(Y))
D EDITFM(BIDA)
D FULL^VALM1
D RESET
Q
;
;
;----------
ADDFM ;EP
;---> Add a new NDC Code by Fileman (not Screenman).
;
D SETVARS^BIUTL5
N BIDA,DIR,Y
F D Q:($G(Y)=-1)
.D TITLE^BIUTL5("ADD A NEW NDC CODE")
.D TEXT1
.;
.N DIR S DIR(0)="FOA",DIR("A")=" Enter NDC Code: "
.S DIR("?")=" Entry must contain 10 or 11 digits and 2 dashes."
.D ^DIR
.I $D(DIRUT) S Y=-1 Q
.S BIENTRY=Y
.;---> Pattern match for NDC format. ALT: I $L($P(X,"-")),$L($P(X,"-",2)),$L($P(X,"-",3))
.I ($L(BIENTRY)>13)!($L(BIENTRY)<12)!(BIENTRY'?.N1"-".N1"-".N) D Q
..W !!?5,"Entry must contain 10 or 11 digits and 2 dashes. Try again."
..N BIPOP D DIRZ^BIUTL3(.BIPOP) S:$G(BIPOP) Y=-1
.;
.;---> Pattern match is good, now check for duplicate.
.;---> If this "new" NDC Number already exists, give opportunity to edit.
.I $D(^BINDC("B",BIENTRY)) D Q
..S BIDA=$O(^BINDC("B",BIENTRY,0))
..D CLEAR^VALM1,FULL^VALM1,TITLE^BIUTL5("ADD A NEW NDC CODE")
..W !!?5,"The NDC Number you entered, ",BIENTRY,", already exists!"
..W !!?5,"NOTE: It may be Inactive. Try displaying Inactive NDC Numbers"
..W !?11,"as well as Active ones."
..W !!?5,"Would you like to edit this NDC Code?"
..S DIR("?")=" Enter YES to edit this NDC Code, or NO to try again."
..S DIR(0)="Y",DIR("A")=" Enter Yes or No",DIR("B")="Yes"
..D ^DIR W !
..I $D(DIRUT)!'Y K BIDA Q
..;---> Edit this NDC, then quit Add loop.
..D EDITFM(BIDA) S Y=-1 Q
.;
.;---> Okay, so this is a valid NEW NDC Code. Now get Vaccine/CVX.
.D CLEAR^VALM1,FULL^VALM1,TITLE^BIUTL5("ADD A NEW NDC CODE")
.W !!?5,"New NDC Code: ",BIENTRY
.W !!," Please choose the Vaccine/CVX Code associated with this NDC Code.",!
.D DIC^BIFMAN(9999999.14,"QEMA",.Y," Select Vaccine: ")
.I Y<0 K Y Q
.N BIVAC S BIVAC=+Y K Y
.;---> Now file new NDC Code.
.D FILE^BIFMAN(9002084.95,BIENTRY,"ML",".02////"_BIVAC,,.Y)
.;---> IF Y<0, CHECK PERMISSIONS.
.I Y<0 D ERRCD^BIUTL2(517,,1) S Y=-1 Q
.;---> New entry successful, now edit.
.S BIDA=+Y
.D EDITFM(+BIDA) S Y=-1 Q
;
Q
;
;
;----------
EDITFM(BIDA) ;EP
;---> Edit the fields of am NDC Code by Fileman.
;---> Parameters:
; 1 - BINDC (req) NDC Code IEN.
;
;---> Check that IEN of NDC Code is present.
I '$G(BIDA) D ERRCD^BIUTL2(515,,1) Q
I '$D(^BINDC(BIDA,0)) D ERRCD^BIUTL2(516,,1) Q
N BI0 S BI0=^BINDC(BIDA,0)
N BIVACP S BIVACP=+$P(BI0,U,2)
D TITLE^BIUTL5("EDIT NDC CODE")
W !?5," NDC Code: ",$P(BI0,U)
W !?5," Vaccine: ",$S(BIVACP:$$VNAME^BIUTL2(BIVACP),1:"Not recorded")
W !?5," CVX: ",$S(BIVACP:$$CODE^BIUTL2(BIVACP,6),1:"")
W !?5," Product: ",$P(BI0,U,4)
W !?5," Manufacturer: " W:+$P(BI0,U,3) $$MNAME^BIUTL2(+$P(BI0,U,3))
W !?5,"Active Status: ",$S($P(BI0,U,6):"Inactive",1:"Active"),!!!
;
S DR=".02;.04;.03;.06"
D DIE^BIFMAN(9002084.95,DR,+BIDA,.BIPOP)
Q
;
;
;----------
RESET ;EP
;---> Update partition for return to Listmanager.
I $D(VALMQUIT) S VALMBCK="Q" Q
D TERM^VALM0 S VALMBCK="R"
D INIT^BINDC,HDR^BINDC()
Q
;
;
;----------
CHGORDR ;EP
;
D CHGORDR^BINDC2
Q
;
;
;----------
TEXT1 ;EP
;;The National Drug Code (NDC) is a unique ten- or eleven-digit
;;3-segment numeric identifier, which serves as a universal product
;;identifier for drugs in commercial distribution.
;;
;;The format for an NDC contains three segments of digits,
;;separated by dashes: labeler code - product code - package code.
;;NDC codes occur in the following grouping of digits:
;; 5-4-2, 4-4-2, 5-3-2, or 5-4-1
;;
;;To enter a new NDC code into the Immunization NDC Table, your entry
;;can take any of the above forms; however, it must contain a total of
;;ten or eleven digits and two dashes.
;;
;;
D PRINTX("TEXT1")
Q
;
;
;----------
TEXT2 ;EP
;;
;;The NDC Number Table will always be listed with the group of
;;all ACTIVE NDC Numbers first, followed by all INACTIVE NDC Numbers.
;;However, within those two groups you may select the order in which
;;the NDC Numbers are displayed, as follows:
;;
;; 1) By NDC Code (alphanumeric)
;; 2) By Vaccine Name, then by NDC Code
;;
D PRINTX("TEXT2")
Q
;
;
;----------
INACTA ;EP
;---> Automatically Inactivate old NDC Numbers that either have expired
;---> or have no Expiration Date.
;
D FULL^VALM1,TITLE^BIUTL5("INACTIVATE OLD NDC NUMBERS"),TEXT3^BINDC
N DIR,Y D INACTA1
D ^DIR
S:$D(DIRUT) BIPOP=1
I Y'=1 D Q
.W !!?5,"Okay. NO changes made!" D DIRZ^BIUTL3()
.D RESET
;
D TITLE^BIUTL5("INACTIVATE OLD NDC NUMBERS"),TEXT33^BINDC,INACTA1
D ^DIR
S:$D(DIRUT) BIPOP=1
I Y'=1 D Q
.W !!?5,"Okay. NO changes made!" D DIRZ^BIUTL3()
.D RESET
;
D INACTLN
D RESET
Q
;
;
;----------
INACTA1 ;EP
;---> Set DIR values for linelabel INACTA.
S DIR(0)="YA"
S DIR("A")=" Please answer either YES or NO: ",DIR("B")="NO"
S DIR("?",1)=" Enter YES to automatically Inactivate NDC Numbers, "
S DIR("?")=" enter NO to make no changes."
Q
;
;
;----------
INACTLN ;EP
;---> Inactivate all NDC Numbers that either have expired or have
;---> no Expiration Date.
;
D ^XBKVAR
N M,N S M=0,N=0
F S N=$O(^BINDC(N)) Q:'N D
.Q:'$D(^BINDC(N,0))
.;---> Do not Inactivate if Exp Date is later than Today.
.Q:($P(^BINDC(N,0),"^",9)>$G(DT))
.;---> Quit if this NDC Number is already Inactive.
.Q:($P(^BINDC(N,0),"^",3)=1)
.;---> Inactivate this NDC Number.
.S $P(^BINDC(N,0),"^",3)=1,M=M+1
W !!?5,"Done. ",M," NDC Numbers have been Inactivated." D DIRZ^BIUTL3()
Q
;
;
;----------
PRINTX(BILINL,BITAB) ;EP
Q:$G(BILINL)=""
N I,T,X S T="" S:'$D(BITAB) BITAB=5 F I=1:1:BITAB S T=T_" "
F I=1:1 S X=$T(@BILINL+I) Q:X'[";;" W !,T,$P(X,";;",2)
Q
BINDC1 ;IHS/CMI/MWR - EDIT NDC NUMBERS.; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;**9**;OCT 01,2014
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; EDIT NDC NUMBER FIELDS.
+4 ;
+5 ;
+6 ;----------
INIT ;EP
+1 ;---> Initialize variables and list array.
+2 ;
+3 SET VALMSG="Enter ?? for more actions."
+4 SET VALM("TITLE")=$$LMVER^BILOGO
+5 ;
+6 ;---> Build Listmanager array.
+7 KILL ^TMP("BINDC",$JOB),BINDC,BITMP
+8 NEW BIENT,BILINE,BITMP
SET BIENT=0
SET BILINE=0
+9 ;---> BICOLL=Order of Listing (see linelabel CHGORDR below.
+10 IF '$GET(BICOLL)
SET BICOLL=1
+11 ;---> Exclude inactive NDCs unless BIINACT=1. vvv83
+12 IF '$GET(BIINACT)
SET BIINACT=0
+13 ;
+14 NEW BIIEN
SET BIIEN=0
+15 FOR
SET BIIEN=$ORDER(^BINDC(BIIEN))
IF 'BIIEN
QUIT
Begin DoDot:1
+16 IF '$DATA(^BINDC(BIIEN,0))
KILL ^BINDC(BIIEN)
QUIT
+17 NEW BINDC,BIVACP,BIVNAM,BICVX,BIMAN,BIPROD,BIACT,W,X,Y,Z
+18 SET Y=^BINDC(BIIEN,0)
SET BINDC=$PIECE(Y,U)
SET BIVACP=+$PIECE(Y,U,2)
+19 SET BIVNAM=$$VNAME^BIUTL2(BIVACP)
+20 SET BICVX=$$CODE^BIUTL2(BIVACP,6)
IF BICVX=""
SET BICVX=999
+21 SET BIPROD=$EXTRACT($PIECE(Y,U,4),1,12)
IF BIPROD=""
SET BIPROD="Not Recorded"
+22 SET BIMAN=+$PIECE(Y,U,3)
SET BIMAN=$$MNAME^BIUTL2(BIMAN)
+23 ;1=inactive
SET BIACT=+$PIECE(Y,U,6)
+24 ;---> Quit if excluding Inactive NDCs.
+25 IF ('BIINACT&BIACT=1)
QUIT
+26 ;---> If no Exp Date, set Exp Date=last in list.
+27 ;Future, if Exp Date: S BIEXP=+$P(Y,U,?) S:'BIEXP BIEXP=9999999
+28 Begin DoDot:2
+29 IF BICOLL=2
SET W=BIVNAM
SET X=BINDC
SET Y=BIPROD
SET Z=BIMAN
QUIT
+30 SET W=BINDC
SET X=BIVNAM
SET Y=BIPROD
SET Z=BIMAN
QUIT
+31 ;---> Other possible orders:
+32 ;I BICOLL=3 S W=BINDC,X=BIVNAM,Y=BIEXP,Z=BICVX Q
+33 ;I BICOLL=4 S W=BIVNAM,X=BICVX,Y=BIEXP,Z=BINDC Q
End DoDot:2
+34 SET BITMP(BIACT,W,X,Y,Z,BIIEN)=BIIEN
End DoDot:1
+35 ;
+36 NEW N
SET N=""
FOR
SET N=$ORDER(BITMP(N))
IF (N="")
QUIT
Begin DoDot:1
+37 ;---> Place a linefeed between Active and Inactive.
+38 IF N
DO WRITE(.BILINE,,,BIENT)
+39 ;
+40 NEW M
SET M=""
FOR
SET M=$ORDER(BITMP(N,M))
IF (M="")
QUIT
Begin DoDot:2
+41 NEW L
SET L=""
FOR
SET L=$ORDER(BITMP(N,M,L))
IF (L="")
QUIT
Begin DoDot:3
+42 NEW K
SET K=""
FOR
SET K=$ORDER(BITMP(N,M,L,K))
IF (K="")
QUIT
Begin DoDot:4
+43 NEW J
SET J=""
FOR
SET J=$ORDER(BITMP(N,M,L,K,J))
IF (J="")
QUIT
Begin DoDot:5
+44 NEW P
SET P=""
FOR
SET P=$ORDER(BITMP(N,M,L,K,J,P))
IF (P="")
QUIT
Begin DoDot:6
+45 DO LINE(BITMP(N,M,L,K,J,P),.BILINE,.BIENT)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+46 ;
+47 ;---> Finish up Listmanager List Count.
+48 SET VALMCNT=BILINE
+49 IF VALMCNT>12
Begin DoDot:1
+50 ;
+51 ;---> Display number of NDCs in list.
+52 NEW Y
SET Y=VALMCNT
IF $GET(BIINACT)
SET Y=Y-1
+53 SET VALMSG=Y_" NDCs: Scroll down to view more, or type ??."
End DoDot:1
+54 QUIT
+55 ;
+56 ;
+57 ;----------
LINE(BIIEN,BILINE,BIENT) ;EP
+1 ;---> Gather data for each NDC and write to ^TMP.
+2 ;---> Parameters:
+3 ; 1 - BIIEN (req) IEN of NDC.
+4 ; 2 - BILINE (ret) Last line# written.
+5 ; 3 - BIENT (opt) Entry Number for LM selection in VALMY
+6 ;
+7 NEW BI0,X,Y
+8 SET BI0=^BINDC(BIIEN,0)
+9 ;
+10 ;---> Set Item# and build Item# array=IEN of Vaccine.
+11 SET BIENT=BIENT+1
SET BINDC(BIENT)=BIIEN
+12 ;
+13 ;---> Item#.
+14 SET X=" "_$SELECT(BIENT<10:" "_BIENT,1:BIENT)
+15 ;
+16 ;---> NDC Code.
+17 SET X=X_" "_$PIECE(BI0,U)
+18 SET X=$$PAD^BIUTL5(X,21,".")
+19 ;
+20 ;---> Vaccine.
+21 NEW BIVACP
SET BIVACP=+$PIECE(BI0,U,2)
+22 Begin DoDot:1
+23 IF 'BIVACP
SET X=X_"UNKNOWN"
QUIT
+24 SET X=X_$$VNAME^BIUTL2(BIVACP)
End DoDot:1
+25 SET X=$$PAD^BIUTL5(X,32,".")
+26 ;
+27 ;---> CVX.
+28 NEW BICVX
SET BICVX=$$CODE^BIUTL2(BIVACP,6)
IF ('BICVX)
SET BICVX="UNK"
+29 IF ($LENGTH(BICVX))=1
SET BICVX=".."_BICVX
IF ($LENGTH(BICVX))=2
SET BICVX="."_BICVX
+30 SET X=X_BICVX
+31 SET X=$$PAD^BIUTL5(X,38,".")
+32 ;
+33 ;---> Product.
+34 NEW BIPROD
SET BIPROD=$EXTRACT($PIECE(BI0,U,4),1,12)
IF BIPROD=""
SET BIPROD="Not Recorded"
+35 SET X=X_BIPROD
+36 SET X=$$PAD^BIUTL5(X,53,".")
+37 ;
+38 ;---> Manufacturer.
+39 NEW BIMAN
Begin DoDot:1
+40 SET BIMAN=+$PIECE(BI0,U,3)
+41 IF 'BIMAN
SET BIMAN="Not Recorded"
QUIT
+42 SET BIMAN=$EXTRACT($$MNAME^BIUTL2(BIMAN),1,16)
End DoDot:1
+43 SET X=X_BIMAN
+44 SET X=$$PAD^BIUTL5(X,71,".")
+45 ;
+46 ;---> Active/Inactive Status.
+47 SET X=X_$SELECT($PIECE(BI0,U,6)=1:"Inactive",1:"Active")
+48 ;
+49 ;---> Set this Vaccine display row and index in ^TMP.
+50 DO WRITE(.BILINE,X,,BIENT)
+51 QUIT
+52 ;
+53 ;
+54 ;----------
WRITE(BILINE,BIVAL,BIBLNK,BIENT) ;EP
+1 ;---> Write lines to ^TMP (see documentation in ^BIW).
+2 ;---> Parameters:
+3 ; 1 - BILINE (ret) Last line# written.
+4 ; 2 - BIVAL (opt) Value/text of line (Null=blank line).
+5 ; 3 - BIBLNK (opt) Number of blank lines to add after line sent.
+6 ; 4 - BIENT (opt) Entry Number for LM selection in VALMY
+7 ;
+8 IF '$DATA(BILINE)
QUIT
+9 DO WL^BIW(.BILINE,"BINDC",$GET(BIVAL),$GET(BIBLNK),$GET(BIENT))
+10 QUIT
+11 ;
+12 ;
+13 ;----------
EDITNDC(BINEW) ;EP
+1 ;---> Add or Edit an NDC Number.
+2 ;---> Parameters:
+3 ; 2 - BINEW (opt) 1=new NDC number being added; 0/""=edit.
+4 ;
+5 NEW BIDA
+6 ;---> If BINEW, add a new NDC Number and quit.
+7 ;I $G(BINEW) D EDITSCR(,1) D RESET Q
+8 IF $GET(BINEW)
Begin DoDot:1
+9 DO ADDFM
+10 DO FULL^VALM1
DO RESET
End DoDot:1
QUIT
+11 ;
+12 ;---> This is an Edit, so continue.
+13 ;---> Call the Listmanager Generic Selector of items displayed.
+14 NEW VALMY
+15 DO EN^VALM2(XQORNOD(0),"OS")
+16 ;
+17 ;---> Check that a Listman Item was passed.
+18 IF '$DATA(VALMY)
DO ERRCD^BIUTL2(406,,1)
DO RESET
QUIT
+19 ;---> Now set Y=Item# selected from the list.
+20 NEW Y
SET Y=$ORDER(VALMY(0))
+21 IF '$GET(Y)
DO ERRCD^BIUTL2(406,,1)
DO RESET
QUIT
+22 IF $GET(BINDC(Y))=""
DO ERRCD^BIUTL2(511,,1)
DO RESET
QUIT
+23 NEW BIDA
SET BIDA=+BINDC(Y)
+24 IF $GET(^BINDC(BIDA,0))=""
DO ERRCD^BIUTL2(515,,1)
DO RESET
QUIT
+25 ;---> Use next line and called code if you want to use Screenman.
+26 ;D EDITSCR(+BINDC(Y))
+27 DO EDITFM(BIDA)
+28 DO FULL^VALM1
+29 DO RESET
+30 QUIT
+31 ;
+32 ;
+33 ;----------
ADDFM ;EP
+1 ;---> Add a new NDC Code by Fileman (not Screenman).
+2 ;
+3 DO SETVARS^BIUTL5
+4 NEW BIDA,DIR,Y
+5 FOR
Begin DoDot:1
+6 DO TITLE^BIUTL5("ADD A NEW NDC CODE")
+7 DO TEXT1
+8 ;
+9 NEW DIR
SET DIR(0)="FOA"
SET DIR("A")=" Enter NDC Code: "
+10 SET DIR("?")=" Entry must contain 10 or 11 digits and 2 dashes."
+11 DO ^DIR
+12 IF $DATA(DIRUT)
SET Y=-1
QUIT
+13 SET BIENTRY=Y
+14 ;---> Pattern match for NDC format. ALT: I $L($P(X,"-")),$L($P(X,"-",2)),$L($P(X,"-",3))
+15 IF ($LENGTH(BIENTRY)>13)!($LENGTH(BIENTRY)<12)!(BIENTRY'?.N1"-".N1"-".N)
Begin DoDot:2
+16 WRITE !!?5,"Entry must contain 10 or 11 digits and 2 dashes. Try again."
+17 NEW BIPOP
DO DIRZ^BIUTL3(.BIPOP)
IF $GET(BIPOP)
SET Y=-1
End DoDot:2
QUIT
+18 ;
+19 ;---> Pattern match is good, now check for duplicate.
+20 ;---> If this "new" NDC Number already exists, give opportunity to edit.
+21 IF $DATA(^BINDC("B",BIENTRY))
Begin DoDot:2
+22 SET BIDA=$ORDER(^BINDC("B",BIENTRY,0))
+23 DO CLEAR^VALM1
DO FULL^VALM1
DO TITLE^BIUTL5("ADD A NEW NDC CODE")
+24 WRITE !!?5,"The NDC Number you entered, ",BIENTRY,", already exists!"
+25 WRITE !!?5,"NOTE: It may be Inactive. Try displaying Inactive NDC Numbers"
+26 WRITE !?11,"as well as Active ones."
+27 WRITE !!?5,"Would you like to edit this NDC Code?"
+28 SET DIR("?")=" Enter YES to edit this NDC Code, or NO to try again."
+29 SET DIR(0)="Y"
SET DIR("A")=" Enter Yes or No"
SET DIR("B")="Yes"
+30 DO ^DIR
WRITE !
+31 IF $DATA(DIRUT)!'Y
KILL BIDA
QUIT
+32 ;---> Edit this NDC, then quit Add loop.
+33 DO EDITFM(BIDA)
SET Y=-1
QUIT
End DoDot:2
QUIT
+34 ;
+35 ;---> Okay, so this is a valid NEW NDC Code. Now get Vaccine/CVX.
+36 DO CLEAR^VALM1
DO FULL^VALM1
DO TITLE^BIUTL5("ADD A NEW NDC CODE")
+37 WRITE !!?5,"New NDC Code: ",BIENTRY
+38 WRITE !!," Please choose the Vaccine/CVX Code associated with this NDC Code.",!
+39 DO DIC^BIFMAN(9999999.14,"QEMA",.Y," Select Vaccine: ")
+40 IF Y<0
KILL Y
QUIT
+41 NEW BIVAC
SET BIVAC=+Y
KILL Y
+42 ;---> Now file new NDC Code.
+43 DO FILE^BIFMAN(9002084.95,BIENTRY,"ML",".02////"_BIVAC,,.Y)
+44 ;---> IF Y<0, CHECK PERMISSIONS.
+45 IF Y<0
DO ERRCD^BIUTL2(517,,1)
SET Y=-1
QUIT
+46 ;---> New entry successful, now edit.
+47 SET BIDA=+Y
+48 DO EDITFM(+BIDA)
SET Y=-1
QUIT
End DoDot:1
IF ($GET(Y)=-1)
QUIT
+49 ;
+50 QUIT
+51 ;
+52 ;
+53 ;----------
EDITFM(BIDA) ;EP
+1 ;---> Edit the fields of am NDC Code by Fileman.
+2 ;---> Parameters:
+3 ; 1 - BINDC (req) NDC Code IEN.
+4 ;
+5 ;---> Check that IEN of NDC Code is present.
+6 IF '$GET(BIDA)
DO ERRCD^BIUTL2(515,,1)
QUIT
+7 IF '$DATA(^BINDC(BIDA,0))
DO ERRCD^BIUTL2(516,,1)
QUIT
+8 NEW BI0
SET BI0=^BINDC(BIDA,0)
+9 NEW BIVACP
SET BIVACP=+$PIECE(BI0,U,2)
+10 DO TITLE^BIUTL5("EDIT NDC CODE")
+11 WRITE !?5," NDC Code: ",$PIECE(BI0,U)
+12 WRITE !?5," Vaccine: ",$SELECT(BIVACP:$$VNAME^BIUTL2(BIVACP),1:"Not recorded")
+13 WRITE !?5," CVX: ",$SELECT(BIVACP:$$CODE^BIUTL2(BIVACP,6),1:"")
+14 WRITE !?5," Product: ",$PIECE(BI0,U,4)
+15 WRITE !?5," Manufacturer: "
IF +$PIECE(BI0,U,3)
WRITE $$MNAME^BIUTL2(+$PIECE(BI0,U,3))
+16 WRITE !?5,"Active Status: ",$SELECT($PIECE(BI0,U,6):"Inactive",1:"Active"),!!!
+17 ;
+18 SET DR=".02;.04;.03;.06"
+19 DO DIE^BIFMAN(9002084.95,DR,+BIDA,.BIPOP)
+20 QUIT
+21 ;
+22 ;
+23 ;----------
RESET ;EP
+1 ;---> Update partition for return to Listmanager.
+2 IF $DATA(VALMQUIT)
SET VALMBCK="Q"
QUIT
+3 DO TERM^VALM0
SET VALMBCK="R"
+4 DO INIT^BINDC
DO HDR^BINDC()
+5 QUIT
+6 ;
+7 ;
+8 ;----------
CHGORDR ;EP
+1 ;
+2 DO CHGORDR^BINDC2
+3 QUIT
+4 ;
+5 ;
+6 ;----------
TEXT1 ;EP
+1 ;;The National Drug Code (NDC) is a unique ten- or eleven-digit
+2 ;;3-segment numeric identifier, which serves as a universal product
+3 ;;identifier for drugs in commercial distribution.
+4 ;;
+5 ;;The format for an NDC contains three segments of digits,
+6 ;;separated by dashes: labeler code - product code - package code.
+7 ;;NDC codes occur in the following grouping of digits:
+8 ;; 5-4-2, 4-4-2, 5-3-2, or 5-4-1
+9 ;;
+10 ;;To enter a new NDC code into the Immunization NDC Table, your entry
+11 ;;can take any of the above forms; however, it must contain a total of
+12 ;;ten or eleven digits and two dashes.
+13 ;;
+14 ;;
+15 DO PRINTX("TEXT1")
+16 QUIT
+17 ;
+18 ;
+19 ;----------
TEXT2 ;EP
+1 ;;
+2 ;;The NDC Number Table will always be listed with the group of
+3 ;;all ACTIVE NDC Numbers first, followed by all INACTIVE NDC Numbers.
+4 ;;However, within those two groups you may select the order in which
+5 ;;the NDC Numbers are displayed, as follows:
+6 ;;
+7 ;; 1) By NDC Code (alphanumeric)
+8 ;; 2) By Vaccine Name, then by NDC Code
+9 ;;
+10 DO PRINTX("TEXT2")
+11 QUIT
+12 ;
+13 ;
+14 ;----------
INACTA ;EP
+1 ;---> Automatically Inactivate old NDC Numbers that either have expired
+2 ;---> or have no Expiration Date.
+3 ;
+4 DO FULL^VALM1
DO TITLE^BIUTL5("INACTIVATE OLD NDC NUMBERS")
DO TEXT3^BINDC
+5 NEW DIR,Y
DO INACTA1
+6 DO ^DIR
+7 IF $DATA(DIRUT)
SET BIPOP=1
+8 IF Y'=1
Begin DoDot:1
+9 WRITE !!?5,"Okay. NO changes made!"
DO DIRZ^BIUTL3()
+10 DO RESET
End DoDot:1
QUIT
+11 ;
+12 DO TITLE^BIUTL5("INACTIVATE OLD NDC NUMBERS")
DO TEXT33^BINDC
DO INACTA1
+13 DO ^DIR
+14 IF $DATA(DIRUT)
SET BIPOP=1
+15 IF Y'=1
Begin DoDot:1
+16 WRITE !!?5,"Okay. NO changes made!"
DO DIRZ^BIUTL3()
+17 DO RESET
End DoDot:1
QUIT
+18 ;
+19 DO INACTLN
+20 DO RESET
+21 QUIT
+22 ;
+23 ;
+24 ;----------
INACTA1 ;EP
+1 ;---> Set DIR values for linelabel INACTA.
+2 SET DIR(0)="YA"
+3 SET DIR("A")=" Please answer either YES or NO: "
SET DIR("B")="NO"
+4 SET DIR("?",1)=" Enter YES to automatically Inactivate NDC Numbers, "
+5 SET DIR("?")=" enter NO to make no changes."
+6 QUIT
+7 ;
+8 ;
+9 ;----------
INACTLN ;EP
+1 ;---> Inactivate all NDC Numbers that either have expired or have
+2 ;---> no Expiration Date.
+3 ;
+4 DO ^XBKVAR
+5 NEW M,N
SET M=0
SET N=0
+6 FOR
SET N=$ORDER(^BINDC(N))
IF 'N
QUIT
Begin DoDot:1
+7 IF '$DATA(^BINDC(N,0))
QUIT
+8 ;---> Do not Inactivate if Exp Date is later than Today.
+9 IF ($PIECE(^BINDC(N,0),"^",9)>$GET(DT))
QUIT
+10 ;---> Quit if this NDC Number is already Inactive.
+11 IF ($PIECE(^BINDC(N,0),"^",3)=1)
QUIT
+12 ;---> Inactivate this NDC Number.
+13 SET $PIECE(^BINDC(N,0),"^",3)=1
SET M=M+1
End DoDot:1
+14 WRITE !!?5,"Done. ",M," NDC Numbers have been Inactivated."
DO DIRZ^BIUTL3()
+15 QUIT
+16 ;
+17 ;
+18 ;----------
PRINTX(BILINL,BITAB) ;EP
+1 IF $GET(BILINL)=""
QUIT
+2 NEW I,T,X
SET T=""
IF '$DATA(BITAB)
SET BITAB=5
FOR I=1:1:BITAB
SET T=T_" "
+3 FOR I=1:1
SET X=$TEXT(@BILINL+I)
IF X'[";;"
QUIT
WRITE !,T,$PIECE(X,";;",2)
+4 QUIT
