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

BGP4CTL.m

Go to the documentation of this file.
  1. BGP4CTL ; IHS/CMI/LAB - DISPLAY IND LISTS ;
  1. ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
  1. ;; ;
  1. EP(BGPTAXI) ;EP - CALLED FROM OPTION
  1. NEW BGPRPTTT,BGPRPTT1,BGPRPTT2
  1. D EN
  1. Q
  1. EOJ ;EP
  1. D EN^XBVK("BGP")
  1. Q
  1. ;; ;
  1. EN ;EP -- main entry point for
  1. D EN^VALM("BGP 14 CMS TAXONOMY EDIT")
  1. D CLEAR^VALM1
  1. D FULL^VALM1
  1. W:$D(IOF) @IOF
  1. D EOJ
  1. Q
  1. ;
  1. HDR ; -- header code
  1. S VALMHDR(1)="Updating the "_BGPTAXN_" taxonomy"
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. I BGPTAXJ="L" D LAB Q
  1. K BGPLAB S BGPHIGH="",C=0
  1. S BGPX=0 F S BGPX=$O(^ATXAX(BGPTAXI,21,BGPX)) Q:BGPX'=+BGPX D
  1. .S C=C+1
  1. .S BGPLABI=$P(^ATXAX(BGPTAXI,21,BGPX,0),U)
  1. .S BGPLAB(C,0)=C_") "_$$VAL^XBDIQ1($P(^ATXAX(BGPTAXI,0),U,15),BGPLABI,.01)
  1. .S BGPLAB("IDX",C,C)=BGPLABI
  1. .Q
  1. S (VALMCNT,BGPHIGH)=C
  1. Q
  1. LAB ;
  1. K BGPLAB S BGPHIGH="",C=0
  1. S BGPX=0 F S BGPX=$O(^ATXLAB(BGPTAXI,21,BGPX)) Q:BGPX'=+BGPX D
  1. .S C=C+1
  1. .S BGPLABI=$P(^ATXLAB(BGPTAXI,21,BGPX,0),U)
  1. .S BGPLAB(C,0)=C_") "_$P($G(^LAB(60,BGPLABI,0)),U)
  1. .S BGPLAB("IDX",C,C)=BGPLABI
  1. .Q
  1. S (VALMCNT,BGPHIGH)=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. W ! K DIR
  1. S DIR(0)="NO^1:"_BGPHIGH,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 BGPLABI=BGPLAB("IDX",Y,Y)
  1. ;sure
  1. I BGPTAXJ="L" K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$P(^LAB(60,BGPLABI,0),U)_" lab test",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1. I BGPTAXJ="T" K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$$VAL^XBDIQ1($P(^ATXAX(BGPTAXI,0),U,15),BGPLABI,.01)_" "_$$VAL^XBDIQ1(9002226,BGPTAXI,.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 BGPTAXJ="L" S DA(1)=BGPTAXI,DA=$O(^ATXLAB(BGPTAXI,21,"B",BGPLABI,0)),DIE="^ATXLAB("_BGPTAXI_",21,",DR=".01///@" D ^DIE
  1. I BGPTAXJ="T" S DA(1)=BGPTAXI,DA=$O(^ATXAX(BGPTAXI,21,"B",BGPLABI,0)),DIE="^ATXAX("_BGPTAXI_",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 BGPTAXJ="L" D LABADD G ADDX
  1. K DIC
  1. S DIC(0)="AEMQ",DIC=$P(^ATXAX(BGPTAXI,0),U,15) D ^DIC
  1. I Y=-1 G ADDX
  1. I $D(^ATXAX(BGPTAXI,21,"B",+Y)) W !!,"That item is already in the taxonomy." H 2 G ADD
  1. S DA=BGPTAXI
  1. S (X,BGPTXLI)=+Y
  1. S BGPFILE=$P(^ATXAX(BGPTAXI,0),U,15)
  1. S DA(1)=BGPTAXI
  1. S DIC="^ATXAX("_DA_",21,"
  1. S DIC(0)="L",DIC("DR")=".02////"_BGPTXLI K DD,DO
  1. S:'$D(^ATXAX(DA,21,0)) ^ATXAX(DA,21,0)="^9002226.02101A"
  1. D FILE^DICN
  1. I '$D(^ATXAX(BGPTAXI,21,"B",BGPTXLI)) 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(BGPTAXI,21,"B",+Y)) W !!,"Lab test ",$P(^LAB(60,+Y,0),U)," is already in the taxonomy." H 2 G ADD
  1. S DA=BGPTAXI
  1. S (X,BGPTXLI)=+Y
  1. S DA(1)=BGPTAXI
  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(BGPTAXI,21,"B",BGPTXLI)) W !!,"adding lab test failed." H 2 G ADD
  1. ADDX ;
  1. K DIC,DA,DR,BGPTXLI,DD,DO,BGPFILE
  1. D BACK
  1. Q