Routine: BGP5XTL

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

 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 ;; ;

EP(BGPTAXI) ;EP - CALLED FROM OPTION

 D EN

EOJ ;EP

 D EN^XBVK("BGP")

 ;; ;

EN ;EP -- main entry point for

 D EN^VALM("BGP 15 TAXONOMY EDIT")

 D CLEAR^VALM1

 D FULL^VALM1

 W:$D(IOF) @IOF

 D EOJ

HDR ; -- header code

 S VALMHDR(1)="Updating the "_$P(^ATXLAB(BGPTAXI,0),U)_" taxonomy"

INIT ; -- init variables and list array

 K BGPLAB S BGPHIGH="",C=0

 S BGPX=0 F  S BGPX=$O(^ATXLAB(BGPTAXI,21,BGPX)) Q:BGPX'=+BGPX  D

 .S C=C+1

 .S BGPLABI=$P(^ATXLAB(BGPTAXI,21,BGPX,0),U)

 .S BGPLAB(C,0)=C_")  "_$P($G(^LAB(60,BGPLABI,0)),U)

 .S BGPLAB("IDX",C,C)=BGPLABI

.Q

 S (VALMCNT,BGPHIGH)=C

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

EXIT ; -- exit code

EXPND ; -- expand code

BACK ;go back to listman

 D TERM^VALM0

 S VALMBCK="R"

 D INIT

 D HDR

 K DIR

 K X,Y,Z,I

REM ;

 W ! K DIR

 S DIR(0)="NO^1:"_BGPHIGH,DIR("A")="Remove Which Lab test"

 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 BGPLABI=BGPLAB("IDX",Y,Y)

 ;sure

 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

 I 'Y G REM

 I $D(DIRUT) G REMX

 D ^XBFMK

 S DA(1)=BGPTAXI,DA=$O(^ATXLAB(BGPTAXI,21,"B",BGPLABI,0)),DIE="^ATXLAB("_BGPTAXI_",21,",DR=".01///@" D ^DIE

REMX ;

 D ^XBFMK

 D BACK

ADD ;EP - add an item to the selected list - called from a protocol

 D FULL^VALM1

W !

 K DIC

 S DIC(0)="AEMQ",DIC="^LAB(60,",DIC("A")="Which LAB Test: " D ^DIC

 I Y=-1 G ADDX

 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

 S DA=BGPTAXI

 S (X,BGPTAXLI)=+Y

 S DA(1)=BGPTAXI

 S DIC="^ATXLAB("_DA_",21,"

 S DIC(0)="L" K DD,DO

 S:'$D(^ATXLAB(DA,21,0)) ^ATXLAB(DA,21,0)="^9002228.02101PA"

 D FILE^DICN

 I '$D(^ATXLAB(BGPTAXI,21,"B",BGPTAXLI)) W !!,"adding lab test failed." H 2 G ADD

ADDX ;

 K DIC,DA,DR,BGPTAXLI,DD,DO

 D BACK

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

 +1       ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 +2       ;; ;

EP(BGPTAXI) ;EP - CALLED FROM OPTION

 +1        DO EN

 +2        QUIT

EOJ       ;EP

 +1        DO EN^XBVK("BGP")

 +2        QUIT

 +3       ;; ;

EN        ;EP -- main entry point for

 +1        DO EN^VALM("BGP 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        SET VALMHDR(1)="Updating the "_$PIECE(^ATXLAB(BGPTAXI,0),U)_" taxonomy"

 +2        QUIT

 +3       ;

INIT      ; -- init variables and list array

 +1        KILL BGPLAB

           SET BGPHIGH=""

           SET C=0

 +2        SET BGPX=0

FOR

               SET BGPX=$ORDER(^ATXLAB(BGPTAXI,21,BGPX))

               IF BGPX'=+BGPX

                   QUIT

               Begin DoDot:1

 +3                SET C=C+1

 +4                SET BGPLABI=$PIECE(^ATXLAB(BGPTAXI,21,BGPX,0),U)

 +5                SET BGPLAB(C,0)=C_")  "_$PIECE($GET(^LAB(60,BGPLABI,0)),U)

 +6                SET BGPLAB("IDX",C,C)=BGPLABI

 +7                QUIT

               End DoDot:1

 +8        SET (VALMCNT,BGPHIGH)=C

 +9        QUIT

 +10      ;

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        SET DIR(0)="NO^1:"_BGPHIGH

           SET DIR("A")="Remove Which Lab test"

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF Y=""

               WRITE !,"No lab test selected."

               GOTO REMX

 +5        IF $DATA(DIRUT)

               WRITE !,"No lab test selected."

               GOTO REMX

 +6        SET BGPLABI=BGPLAB("IDX",Y,Y)

 +7       ;sure

 +8        KILL DIR

           SET DIR(0)="Y"

           SET DIR("A")="Are you sure you want to remove the "_$PIECE(^LAB(60,BGPLABI,0),U)_" lab test"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +9        IF 'Y

               GOTO REM

 +10       IF $DATA(DIRUT)

               GOTO REMX

 +11       DO ^XBFMK

 +12       SET DA(1)=BGPTAXI

           SET DA=$ORDER(^ATXLAB(BGPTAXI,21,"B",BGPLABI,0))

           SET DIE="^ATXLAB("_BGPTAXI_",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        SET DIC(0)="AEMQ"

           SET DIC="^LAB(60,"

           SET DIC("A")="Which LAB Test: "

           DO ^DIC

 +5        IF Y=-1

               GOTO ADDX

 +6        IF $DATA(^ATXLAB(BGPTAXI,21,"B",+Y))

               WRITE !!,"Lab test ",$PIECE(^LAB(60,+Y,0),U)," is already in the taxonomy."

               HANG 2

               GOTO ADD

 +7        SET DA=BGPTAXI

 +8        SET (X,BGPTAXLI)=+Y

 +9        SET DA(1)=BGPTAXI

 +10       SET DIC="^ATXLAB("_DA_",21,"

 +11       SET DIC(0)="L"

           KILL DD,DO

 +12       IF '$DATA(^ATXLAB(DA,21,0))

               SET ^ATXLAB(DA,21,0)="^9002228.02101PA"

 +13       DO FILE^DICN

 +14       IF '$DATA(^ATXLAB(BGPTAXI,21,"B",BGPTAXLI))

               WRITE !!,"adding lab test failed."

               HANG 2

               GOTO ADD

ADDX      ;

 +1        KILL DIC,DA,DR,BGPTAXLI,DD,DO

 +2        DO BACK

 +3        QUIT

BGP5XTL.m