BUDHUTXL ; IHS/CMI/LAB - DISPLAY IND LISTS ;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;; ;
EP(BUDTAXI,BUDTAXT) ;EP - CALLED FROM OPTION
D EN
Q
EOJ ;EP
D EN^XBVK("BUD")
Q
;; ;
EN ;EP -- main entry point for
D EN^VALM("BUD 18 TAXONOMY EDIT")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
D EOJ
Q
;
HDR ; -- header code
I BUDTAXT="LAB" S VALMHDR(1)="Updating the "_$P(^ATXLAB(BUDTAXI,0),U)_" taxonomy"
I BUDTAXT="DRUG" S VALMHDR(1)="Updating the "_$P(^ATXAX(BUDTAXI,0),U)_" taxonomy"
Q
;
INIT ; -- init variables and list array
K BUDLAB S BUDHIGH="",C=0
I BUDTAXT="LAB" S BUDX=0 F S BUDX=$O(^ATXLAB(BUDTAXI,21,BUDX)) Q:BUDX'=+BUDX D
.S C=C+1
.S BUDLABI=$P(^ATXLAB(BUDTAXI,21,BUDX,0),U)
.S BUDLAB(C,0)=C_") "_$P($G(^LAB(60,BUDLABI,0)),U)
.S BUDLAB("IDX",C,C)=BUDLABI
.Q
I BUDTAXT="DRUG" S BUDX=0 F S BUDX=$O(^ATXAX(BUDTAXI,21,BUDX)) Q:BUDX'=+BUDX D
.S C=C+1
.S BUDLABI=$P(^ATXAX(BUDTAXI,21,BUDX,0),U)
.S BUDLAB(C,0)=C_") "_$P($G(^PSDRUG(BUDLABI,0)),U)
.S BUDLAB("IDX",C,C)=BUDLABI
.Q
S (VALMCNT,BUDHIGH)=C
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
BACK ;go back to listman
D TERM^VALM0
S VALMBCK="R"
D INIT
D HDR
K DIR
K X,Y,Z,I
Q
;
REM ;
W ! K DIR
I BUDTAXT="LAB" S DIR(0)="NO^1:"_BUDHIGH,DIR("A")="Remove Which Lab test"
I BUDTAXT="DRUG" S DIR(0)="NO^1:"_BUDHIGH,DIR("A")="Remove Which Drug"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No lab test selected." G REMX
I $D(DIRUT) W !,"No lab test selected." G REMX
S BUDLABI=BUDLAB("IDX",Y,Y)
;sure
I BUDTAXT="LAB" K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$P(^LAB(60,BUDLABI,0),U)_" lab test",DIR("B")="N" KILL DA D ^DIR KILL DIR
I BUDTAXT="DRUG" K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$P(^PSDRUG(BUDLABI,0),U)_" DRUG",DIR("B")="N" KILL DA D ^DIR KILL DIR
I 'Y G REM
I $D(DIRUT) G REMX
D ^XBFMK
I BUDTAXT="LAB" S DA(1)=BUDTAXI,DA=$O(^ATXLAB(BUDTAXI,21,"B",BUDLABI,0)),DIE="^ATXLAB("_BUDTAXI_",21,",DR=".01///@" D ^DIE
I BUDTAXT="DRUG" S DA(1)=BUDTAXI,DA=$O(^ATXAX(BUDTAXI,21,"B",BUDLABI,0)),DIE="^ATXAX("_BUDTAXI_",21,",DR=".01///@" D ^DIE
REMX ;
D ^XBFMK
D BACK
Q
ADD ;EP - add an item to the selected list - called from a protocol
D FULL^VALM1
W !
K DIC
I BUDTAXT="LAB" S DIC(0)="AEMQ",DIC="^LAB(60,",DIC("A")="Which LAB Test: " D ^DIC
I BUDTAXT="DRUG" S DIC(0)="AEMQ",DIC="^PSDRUG(",DIC("A")="Which Drug: " D ^DIC
I Y=-1 G ADDX
I BUDTAXT="LAB" I $D(^ATXLAB(BUDTAXI,21,"B",+Y)) W !!,"Lab test ",$P(^LAB(60,+Y,0),U)," is already in the taxonomy." H 2 G ADD
I BUDTAXT="DRUG" I $D(^ATXAX(BUDTAXI,21,"B",+Y)) W !!,"Drug test ",$P(^PSDRUG(+Y,0),U)," is already in the taxonomy." H 2 G ADD
S DA=BUDTAXI
S (X,BUDTAXLI)=+Y
S DA(1)=BUDTAXI
I BUDTAXT="LAB" S DIC="^ATXLAB("_DA_",21,"
I BUDTAXT="DRUG" S DIC="^ATXAX("_DA_",21,"
S DIC(0)="L" K DD,DO
I BUDTAXT="LAB" S:'$D(^ATXLAB(DA,21,0)) ^ATXLAB(DA,21,0)="^9002228.02101PA"
I BUDTAXT="DRUG" S:'$D(^ATXAX(DA,21,0)) ^ATXAX(DA,21,0)="^9002226.02101A"
D FILE^DICN
I BUDTAXT="LAB" I '$D(^ATXLAB(BUDTAXI,21,"B",BUDTAXLI)) W !!,"adding lab test failed." H 2 G ADD
I BUDTAXT="DRUG" I '$D(^ATXAX(BUDTAXI,21,"B",BUDTAXLI)) W !!,"adding DRUG failed." H 2 G ADD
ADDX ;
K DIC,DA,DR,BUDTAXLI,DD,DO
D BACK
Q
BUDHUTXL ; IHS/CMI/LAB - DISPLAY IND LISTS ;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;; ;
EP(BUDTAXI,BUDTAXT) ;EP - CALLED FROM OPTION
+1 DO EN
+2 QUIT
EOJ ;EP
+1 DO EN^XBVK("BUD")
+2 QUIT
+3 ;; ;
EN ;EP -- main entry point for
+1 DO EN^VALM("BUD 18 TAXONOMY EDIT")
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 IF $DATA(IOF)
WRITE @IOF
+5 DO EOJ
+6 QUIT
+7 ;
HDR ; -- header code
+1 IF BUDTAXT="LAB"
SET VALMHDR(1)="Updating the "_$PIECE(^ATXLAB(BUDTAXI,0),U)_" taxonomy"
+2 IF BUDTAXT="DRUG"
SET VALMHDR(1)="Updating the "_$PIECE(^ATXAX(BUDTAXI,0),U)_" taxonomy"
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 KILL BUDLAB
SET BUDHIGH=""
SET C=0
+2 IF BUDTAXT="LAB"
SET BUDX=0
FOR
SET BUDX=$ORDER(^ATXLAB(BUDTAXI,21,BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+3 SET C=C+1
+4 SET BUDLABI=$PIECE(^ATXLAB(BUDTAXI,21,BUDX,0),U)
+5 SET BUDLAB(C,0)=C_") "_$PIECE($GET(^LAB(60,BUDLABI,0)),U)
+6 SET BUDLAB("IDX",C,C)=BUDLABI
+7 QUIT
End DoDot:1
+8 IF BUDTAXT="DRUG"
SET BUDX=0
FOR
SET BUDX=$ORDER(^ATXAX(BUDTAXI,21,BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+9 SET C=C+1
+10 SET BUDLABI=$PIECE(^ATXAX(BUDTAXI,21,BUDX,0),U)
+11 SET BUDLAB(C,0)=C_") "_$PIECE($GET(^PSDRUG(BUDLABI,0)),U)
+12 SET BUDLAB("IDX",C,C)=BUDLABI
+13 QUIT
End DoDot:1
+14 SET (VALMCNT,BUDHIGH)=C
+15 QUIT
+16 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
BACK ;go back to listman
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO INIT
+4 DO HDR
+5 KILL DIR
+6 KILL X,Y,Z,I
+7 QUIT
+8 ;
REM ;
+1 WRITE !
KILL DIR
+2 IF BUDTAXT="LAB"
SET DIR(0)="NO^1:"_BUDHIGH
SET DIR("A")="Remove Which Lab test"
+3 IF BUDTAXT="DRUG"
SET DIR(0)="NO^1:"_BUDHIGH
SET DIR("A")="Remove Which Drug"
+4 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+5 IF Y=""
WRITE !,"No lab test selected."
GOTO REMX
+6 IF $DATA(DIRUT)
WRITE !,"No lab test selected."
GOTO REMX
+7 SET BUDLABI=BUDLAB("IDX",Y,Y)
+8 ;sure
+9 IF BUDTAXT="LAB"
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to remove the "_$PIECE(^LAB(60,BUDLABI,0),U)_" lab test"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+10 IF BUDTAXT="DRUG"
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to remove the "_$PIECE(^PSDRUG(BUDLABI,0),U)_" DRUG"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+11 IF 'Y
GOTO REM
+12 IF $DATA(DIRUT)
GOTO REMX
+13 DO ^XBFMK
+14 IF BUDTAXT="LAB"
SET DA(1)=BUDTAXI
SET DA=$ORDER(^ATXLAB(BUDTAXI,21,"B",BUDLABI,0))
SET DIE="^ATXLAB("_BUDTAXI_",21,"
SET DR=".01///@"
DO ^DIE
+15 IF BUDTAXT="DRUG"
SET DA(1)=BUDTAXI
SET DA=$ORDER(^ATXAX(BUDTAXI,21,"B",BUDLABI,0))
SET DIE="^ATXAX("_BUDTAXI_",21,"
SET DR=".01///@"
DO ^DIE
REMX ;
+1 DO ^XBFMK
+2 DO BACK
+3 QUIT
ADD ;EP - add an item to the selected list - called from a protocol
+1 DO FULL^VALM1
+2 WRITE !
+3 KILL DIC
+4 IF BUDTAXT="LAB"
SET DIC(0)="AEMQ"
SET DIC="^LAB(60,"
SET DIC("A")="Which LAB Test: "
DO ^DIC
+5 IF BUDTAXT="DRUG"
SET DIC(0)="AEMQ"
SET DIC="^PSDRUG("
SET DIC("A")="Which Drug: "
DO ^DIC
+6 IF Y=-1
GOTO ADDX
+7 IF BUDTAXT="LAB"
IF $DATA(^ATXLAB(BUDTAXI,21,"B",+Y))
WRITE !!,"Lab test ",$PIECE(^LAB(60,+Y,0),U)," is already in the taxonomy."
HANG 2
GOTO ADD
+8 IF BUDTAXT="DRUG"
IF $DATA(^ATXAX(BUDTAXI,21,"B",+Y))
WRITE !!,"Drug test ",$PIECE(^PSDRUG(+Y,0),U)," is already in the taxonomy."
HANG 2
GOTO ADD
+9 SET DA=BUDTAXI
+10 SET (X,BUDTAXLI)=+Y
+11 SET DA(1)=BUDTAXI
+12 IF BUDTAXT="LAB"
SET DIC="^ATXLAB("_DA_",21,"
+13 IF BUDTAXT="DRUG"
SET DIC="^ATXAX("_DA_",21,"
+14 SET DIC(0)="L"
KILL DD,DO
+15 IF BUDTAXT="LAB"
IF '$DATA(^ATXLAB(DA,21,0))
SET ^ATXLAB(DA,21,0)="^9002228.02101PA"
+16 IF BUDTAXT="DRUG"
IF '$DATA(^ATXAX(DA,21,0))
SET ^ATXAX(DA,21,0)="^9002226.02101A"
+17 DO FILE^DICN
+18 IF BUDTAXT="LAB"
IF '$DATA(^ATXLAB(BUDTAXI,21,"B",BUDTAXLI))
WRITE !!,"adding lab test failed."
HANG 2
GOTO ADD
+19 IF BUDTAXT="DRUG"
IF '$DATA(^ATXAX(BUDTAXI,21,"B",BUDTAXLI))
WRITE !!,"adding DRUG failed."
HANG 2
GOTO ADD
ADDX ;
+1 KILL DIC,DA,DR,BUDTAXLI,DD,DO
+2 DO BACK
+3 QUIT
