BUDCUTXL.m

BUDCUTXL ; IHS/CMI/LAB - DISPLAY IND LISTS ;

 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50

 ;; ;

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 15 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

BUDCUTXL  ; IHS/CMI/LAB - DISPLAY IND LISTS ;

 +1       ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50

 +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 15 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