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

BNITAXE.m

Go to the documentation of this file. 
  1. BNITAXE ; IHS/CMI/LAB - taxonomy update community ;
  1.  ;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006
  1.  ;; ;
  1. EP ;EP - CALLED FROM OPTION
  1.  D EN
  1.  Q
  1. EOJ ;EP
  1.  D ^XBFMK
  1.  K BNIITEM,BNIX,BNITAXI,BNIITMI,BNIHIGH,BNITXLI
  1.  Q
  1.  ;; ;
  1. EN ;EP -- main entry point for 
  1.  D EN^VALM("BNI TAXONOMY GENERIC EDIT")
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  D EOJ
  1.  Q
  1.  ;
  1. PAUSE ;EP
  1.  Q:$E(IOST)'="C"!(IO'=IO(0))
  1.  W ! S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q
  1. HDR ; -- header code
  1.  S VALMHDR(1)="Updating the "_BNITAXN_" taxonomy"
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  I BNIFILE=60 D LAB Q
  1.  I $P(^ATXAX(BNITAXI,0),U,13) D CANDISP Q
  1.  K BNIITEM S BNIHIGH="",C=0
  1.  S BNIX=0 F  S BNIX=$O(^ATXAX(BNITAXI,21,BNIX)) Q:BNIX'=+BNIX  D
  1.  .S C=C+1
  1.  .S BNIITMI=$P(^ATXAX(BNITAXI,21,BNIX,0),U)
  1.  .I BNIFILE=9999999.05 S BNIITEM(C,0)=C_")  "_BNIITMI I 1
  1.  .E  S BNIITEM(C,0)=C_")  "_$$VAL^XBDIQ1($P(^ATXAX(BNITAXI,0),U,15),BNIITMI,.01)
  1.  .S BNIITEM("IDX",C,C)=BNIITMI
  1.  .Q
  1.  S (VALMCNT,BNIHIGH)=C
  1.  Q
  1. CANDISP ;
  1.  K BNIITEM S BNIHIGH="",C=0
  1.  S BNIX=0 F  S BNIX=$O(^ATXAX(BNITAXI,21,BNIX)) Q:BNIX'=+BNIX  D
  1.  .S C=C+1
  1.  .S BNIITEM(C,0)=C_")  "_$P(^ATXAX(BNITAXI,21,BNIX,0),U)_"-"_$P(^ATXAX(BNITAXI,21,BNIX,0),U,2)
  1.  .S BNIITEM("IDX",C,C)=BNIX
  1.  .Q
  1.  S (VALMCNT,BNIHIGH)=C
  1.  Q
  1. LAB ;
  1.  K BNIITEM S BNIHIGH="",C=0
  1.  S BNIX=0 F  S BNIX=$O(^ATXLAB(BNITAXI,21,BNIX)) Q:BNIX'=+BNIX  D
  1.  .S C=C+1
  1.  .S BNIITMI=$P(^ATXLAB(BNITAXI,21,BNIX,0),U)
  1.  .S BNIITEM(C,0)=C_")  "_$P($G(^LAB(60,BNIITMI,0)),U)
  1.  .S BNIITEM("IDX",C,C)=BNIITMI
  1.  .Q
  1.  S (VALMCNT,BNIHIGH)=C
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. BACK ;go back to listman
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D INIT
  1.  D HDR
  1.  K DIR
  1.  K X,Y,Z,I
  1.  Q
  1.  ;
  1. REM ;
  1.  D FULL^VALM1
  1.  W !
  1.  I BNIFILE=60,$P(^ATXLAB(BNITAXI,0),U,22) W !!,"The ",$P(^ATXLAB(BNITAXI,0),U)," Taxonomy is READ ONLY.",!,"You can not update it." D PAUSE G REMX
  1.  I BNIFILE'=60,$P(^ATXAX(BNITAXI,0),U,22) W !!,"The ",$P(^ATXAX(BNITAXI,0),U)," Taxonomy is READ ONLY.",!,"You can not update it." D PAUSE G REMX
  1.  W ! K DIR
  1.  I BNIFILE'=60,$P(^ATXTYPE(BNITAXT,0),U,4)=1 D ICD9ADD G REMX
  1.  S DIR(0)="NO^1:"_BNIHIGH,DIR("A")="Remove Which Item"
  1.  D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !,"No item selected." G REMX
  1.  I $D(DIRUT) W !,"No item selected." G REMX
  1.  S BNIITMI=BNIITEM("IDX",Y,Y)
  1.  ;sure
  1.  I BNIFILE=60 K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$P(^LAB(60,BNIITMI,0),U)_" lab test",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I BNITAXT K DIR D
  1.  .S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$S(BNIFILE'=9999999.05:$$VAL^XBDIQ1($P(^ATXAX(BNITAXI,0),U,15),BNIITMI,.01),1:BNIITMI)_" "_$$VAL^XBDIQ1(9002226,BNITAXI,.15),DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I 'Y G REM
  1.  I $D(DIRUT) G REMX
  1.  D ^XBFMK
  1.  I BNIFILE=60 S DA(1)=BNITAXI,DA=$O(^ATXLAB(BNITAXI,21,"B",BNIITMI,0)),DIE="^ATXLAB("_BNITAXI_",21,",DR=".01///@" D ^DIE
  1.  I BNIFILE'=60 S DA(1)=BNITAXI,DA=$O(^ATXAX(BNITAXI,21,"B",BNIITMI,0)),DIE="^ATXAX("_BNITAXI_",21,",DR=".01///@" D ^DIE
  1. REMX ;
  1.  D ^XBFMK
  1.  D BACK
  1.  Q
  1. ADD ;EP - add an item to the selected list - called from a protocol
  1.  D FULL^VALM1
  1.  W !
  1.  I BNIFILE=60,$P(^ATXLAB(BNITAXI,0),U,22) W !!,"The ",$P(^ATXLAB(BNITAXI,0),U)," is READ ONLY.",!,"You can not update it." D PAUSE G ADDX
  1.  I BNIFILE'=60,$P(^ATXAX(BNITAXI,0),U,22) W !!,"The ",$P(^ATXAX(BNITAXI,0),U)," is READ ONLY.",!,"You can not update it." D PAUSE G ADDX
  1.  I BNIFILE=60 D LABADD G ADDX
  1.  I BNIFILE=80 D ICD9ADD G ADDX
  1.  I BNIFILE=80.1 D ICD0ADD G ADDX
  1.  I BNIFILE=81 D ICPTADD G ADDX
  1.  K DIC
  1.  S DIC(0)="AEMQ",DIC=$P(^ATXAX(BNITAXI,0),U,15) D ^DIC
  1.  I Y=-1 G ADDX
  1.  I $D(^ATXAX(BNITAXI,21,"B",$S(BNIFILE'=9999999.05:+Y,1:$P(^AUTTCOM(+Y,0),U,1)))) W !!,"That item is already in the taxonomy." H 2 G ADD
  1.  S DA=BNITAXI
  1.  S (X,BNITXLI)=+Y
  1.  I BNIFILE=9999999.05 S (X,BNITXLI)=$P(^AUTTCOM(+Y,0),U)  ;special processing for community
  1.  S BNIFILE=$P(^ATXAX(BNITAXI,0),U,15)
  1.  S DA(1)=BNITAXI
  1.  S DIC="^ATXAX("_DA_",21,"
  1.  S DIC(0)="L",DIC("DR")=".02////"_BNITXLI K DD,DO
  1.  S:'$D(^ATXAX(DA,21,0)) ^ATXAX(DA,21,0)="^9002226.02101A"
  1.  D FILE^DICN
  1.  I '$D(^ATXAX(BNITAXI,21,"B",BNITXLI)) W !!,"adding ITEM failed." H 2 G ADD
  1.  G ADDX
  1. LABADD ;
  1.  K DIC
  1.  S DIC(0)="AEMQ",DIC="^LAB(60,",DIC("A")="Which LAB Test: " D ^DIC
  1.  I Y=-1 G ADDX
  1.  I $D(^ATXLAB(BNITAXI,21,"B",+Y)) W !!,"Lab test ",$P(^LAB(60,+Y,0),U)," is already in the taxonomy." H 2 G ADD
  1.  S DA=BNITAXI
  1.  S (X,BNITXLI)=+Y
  1.  S DA(1)=BNITAXI
  1.  S DIC="^ATXLAB("_DA_",21,"
  1.  S DIC(0)="L" K DD,DO
  1.  S:'$D(^ATXLAB(DA,21,0)) ^ATXLAB(DA,21,0)="^9002228.02101PA"
  1.  D FILE^DICN
  1.  I '$D(^ATXLAB(BNITAXI,21,"B",BNITXLI)) W !!,"adding lab test failed." H 2 G ADD
  1. ADDX ;
  1.  K DIC,DA,DR,BNITXLI,DD,DO
  1.  D BACK
  1.  Q
  1. ICD9ADD ;
  1.  ;D ICD9ADD^BNITAXF
  1.  Q
  1. ICD0ADD ;
  1.  ;D ICD0ADD^BNITAXH
  1.  Q
  1. ICPTADD ;
  1.  ;D ICPTADD^BNITAXL
  1.  Q