Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BINDC1

BINDC1.m

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