BDMDATL.m

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

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**6**;JUN 14, 2007;Build 6

 ;; ;

EP(BDMTAXI) ;EP - CALLED FROM OPTION

 D EN

 Q

EOJ ;EP

 I '$D(BDMGUI) D EN^XBVK("BDM")

 Q

 ;; ;

EN ;EP -- main entry point for 

 D EN^VALM("BDMDA TAXONOMY EDIT")

 D CLEAR^VALM1

 D FULL^VALM1

 W:$D(IOF) @IOF

 D EOJ

 Q

 ;

HDR ; -- header code

 S VALMHDR(1)="Updating the "_BDMTAXN_" taxonomy"

 S VALMHDR(2)="ITEM NAME",$E(VALMHDR(2),64)="Internal Entry #"

 Q

 ;

INIT ; -- init variables and list array

 I BDMTAXT="L" D LAB Q

 K BDMLAB S BDMHIGH="",C=0

 S BDMX=0 F  S BDMX=$O(^ATXAX(BDMTAXI,21,BDMX)) Q:BDMX'=+BDMX  D

 .S C=C+1

 .S BDMLABI=$P(^ATXAX(BDMTAXI,21,BDMX,0),U)

 .S BDMLAB(C,0)=C_")  "_$$VAL^XBDIQ1($P(^ATXAX(BDMTAXI,0),U,15),BDMLABI,.01),$E(BDMLAB(C,0),65)=BDMLABI

 .S BDMLAB("IDX",C,C)=BDMLABI

 .Q

 S (VALMCNT,BDMHIGH)=C

 Q

LAB ;

 K BDMLAB S BDMHIGH="",C=0

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

 .S C=C+1

 .S BDMLABI=$P(^ATXLAB(BDMTAXI,21,BDMX,0),U)

 .S BDMLAB(C,0)=C_")  "_$P($G(^LAB(60,BDMLABI,0)),U),$E(BDMLAB(C,0),65)=BDMLABI

 .S BDMLAB("IDX",C,C)=BDMLABI

 .Q

 S (VALMCNT,BDMHIGH)=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

 S DIR(0)="NO^1:"_BDMHIGH,DIR("A")="Remove Which Item"

 D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I Y="" W !,"No item selected." G REMX

 I $D(DIRUT) W !,"No item selected." G REMX

 S BDMLABI=BDMLAB("IDX",Y,Y)

 ;sure

 I BDMTAXT="L" K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$P(^LAB(60,BDMLABI,0),U)_" lab test",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I BDMTAXT="T" K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$$VAL^XBDIQ1($P(^ATXAX(BDMTAXI,0),U,15),BDMLABI,.01)_" "_$$VAL^XBDIQ1(9002226,BDMTAXI,.15),DIR("B")="N" KILL DA D ^DIR KILL DIR

 I 'Y G REM

 I $D(DIRUT) G REMX

 D ^XBFMK

 I BDMTAXT="L" S DA(1)=BDMTAXI,DA=$O(^ATXLAB(BDMTAXI,21,"B",BDMLABI,0)),DIE="^ATXLAB("_BDMTAXI_",21,",DR=".01///@" D ^DIE

 I BDMTAXT="T" S DA(1)=BDMTAXI,DA=$O(^ATXAX(BDMTAXI,21,"B",BDMLABI,0)),DIE="^ATXAX("_BDMTAXI_",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 !

 I BDMTAXT="L" D LABADD G ADDX

 K DIC

 S DIC(0)="AEMQ",DIC=$P(^ATXAX(BDMTAXI,0),U,15) D ^DIC

 I Y=-1 G ADDX

 I $D(^ATXAX(BDMTAXI,21,"B",+Y)) W !!,"That item is already in the taxonomy." H 2 G ADD

 S DA=BDMTAXI

 S (X,BDMTXLI)=+Y

 S BDMFILE=$P(^ATXAX(BDMTAXI,0),U,15)

 S DA(1)=BDMTAXI

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

 S DIC(0)="L",DIC("DR")=".02////"_BDMTXLI K DD,DO

 S:'$D(^ATXAX(DA,21,0)) ^ATXAX(DA,21,0)="^9002226.02101A"

 D FILE^DICN

 I '$D(^ATXAX(BDMTAXI,21,"B",BDMTXLI)) W !!,"adding ITEM failed." H 2 G ADD

 G ADDX

LABADD ;

 K DIC

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

 I Y=-1 G ADDX

 S BDMTXLI=+Y

 I '$P(^ATXLAB(BDMTAXI,0),U,11),$O(^LAB(60,BDMTXLI,2,0)) S BDMYN="" D  G:'BDMYN ADDX

 .W !!,"This lab test, ",$P(^LAB(60,BDMTXLI,0),U),", is a panel test and the"

 .W !,"taxonomy ",$P(^ATXLAB(BDMTAXI,0),U)," should not contain panel tests.",!

 .S DIR(0)="Y",DIR("A")="Do you still want to add this lab test to this taxonomy",DIR("B")="N" KILL DA D ^DIR KILL DIR

 .Q:$D(DIRUT)

 .S BDMYN=Y

 I $D(^ATXLAB(BDMTAXI,21,"B",+Y)) W !!,"Lab test ",$P(^LAB(60,+Y,0),U)," is already in the taxonomy." H 2 G ADD

 S DA=BDMTAXI

 S X=BDMTXLI

 S DA(1)=BDMTAXI

 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(BDMTAXI,21,"B",BDMTXLI)) W !!,"adding lab test failed." H 2 G ADD

ADDX ;

 K DIC,DA,DR,BDMTXLI,DD,DO,BDMFILE

 D BACK

 Q

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

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**6**;JUN 14, 2007;Build 6

 +2       ;; ;

EP(BDMTAXI) ;EP - CALLED FROM OPTION

 +1        DO EN

 +2        QUIT 

EOJ       ;EP

 +1        IF '$DATA(BDMGUI)

               DO EN^XBVK("BDM")

 +2        QUIT 

 +3       ;; ;

EN        ;EP -- main entry point for 

 +1        DO EN^VALM("BDMDA 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 "_BDMTAXN_" taxonomy"

 +2        SET VALMHDR(2)="ITEM NAME"

           SET $EXTRACT(VALMHDR(2),64)="Internal Entry #"

 +3        QUIT 

 +4       ;

INIT      ; -- init variables and list array

 +1        IF BDMTAXT="L"

               DO LAB

               QUIT 

 +2        KILL BDMLAB

           SET BDMHIGH=""

           SET C=0

 +3        SET BDMX=0

           FOR 

               SET BDMX=$ORDER(^ATXAX(BDMTAXI,21,BDMX))

               IF BDMX'=+BDMX

                   QUIT 

               Begin DoDot:1

 +4                SET C=C+1

 +5                SET BDMLABI=$PIECE(^ATXAX(BDMTAXI,21,BDMX,0),U)

 +6                SET BDMLAB(C,0)=C_")  "_$$VAL^XBDIQ1($PIECE(^ATXAX(BDMTAXI,0),U,15),BDMLABI,.01)

                   SET $EXTRACT(BDMLAB(C,0),65)=BDMLABI

 +7                SET BDMLAB("IDX",C,C)=BDMLABI

 +8                QUIT 

               End DoDot:1

 +9        SET (VALMCNT,BDMHIGH)=C

 +10       QUIT 

LAB       ;

 +1        KILL BDMLAB

           SET BDMHIGH=""

           SET C=0

 +2        SET BDMX=0

           FOR 

               SET BDMX=$ORDER(^ATXLAB(BDMTAXI,21,BDMX))

               IF BDMX'=+BDMX

                   QUIT 

               Begin DoDot:1

 +3                SET C=C+1

 +4                SET BDMLABI=$PIECE(^ATXLAB(BDMTAXI,21,BDMX,0),U)

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

                   SET $EXTRACT(BDMLAB(C,0),65)=BDMLABI

 +6                SET BDMLAB("IDX",C,C)=BDMLABI

 +7                QUIT 

               End DoDot:1

 +8        SET (VALMCNT,BDMHIGH)=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:"_BDMHIGH

           SET DIR("A")="Remove Which Item"

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF Y=""

               WRITE !,"No item selected."

               GOTO REMX

 +5        IF $DATA(DIRUT)

               WRITE !,"No item selected."

               GOTO REMX

 +6        SET BDMLABI=BDMLAB("IDX",Y,Y)

 +7       ;sure

 +8        IF BDMTAXT="L"

               KILL DIR

               SET DIR(0)="Y"

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

               SET DIR("B")="N"

               KILL DA

               DO ^DIR

               KILL DIR

 +9        IF BDMTAXT="T"

               KILL DIR

               SET DIR(0)="Y"

               SET DIR("A")="Are you sure you want to remove the "_$$VAL^XBDIQ1($PIECE(^ATXAX(BDMTAXI,0),U,15),BDMLABI,.01)_" "_$$VAL^XBDIQ1(9002226,BDMTAXI,.15)

               SET DIR("B")="N"

               KILL DA

               DO ^DIR

               KILL DIR

 +10       IF 'Y

               GOTO REM

 +11       IF $DATA(DIRUT)

               GOTO REMX

 +12       DO ^XBFMK

 +13       IF BDMTAXT="L"

               SET DA(1)=BDMTAXI

               SET DA=$ORDER(^ATXLAB(BDMTAXI,21,"B",BDMLABI,0))

               SET DIE="^ATXLAB("_BDMTAXI_",21,"

               SET DR=".01///@"

               DO ^DIE

 +14       IF BDMTAXT="T"

               SET DA(1)=BDMTAXI

               SET DA=$ORDER(^ATXAX(BDMTAXI,21,"B",BDMLABI,0))

               SET DIE="^ATXAX("_BDMTAXI_",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        IF BDMTAXT="L"

               DO LABADD

               GOTO ADDX

 +4        KILL DIC

 +5        SET DIC(0)="AEMQ"

           SET DIC=$PIECE(^ATXAX(BDMTAXI,0),U,15)

           DO ^DIC

 +6        IF Y=-1

               GOTO ADDX

 +7        IF $DATA(^ATXAX(BDMTAXI,21,"B",+Y))

               WRITE !!,"That item is already in the taxonomy."

               HANG 2

               GOTO ADD

 +8        SET DA=BDMTAXI

 +9        SET (X,BDMTXLI)=+Y

 +10       SET BDMFILE=$PIECE(^ATXAX(BDMTAXI,0),U,15)

 +11       SET DA(1)=BDMTAXI

 +12       SET DIC="^ATXAX("_DA_",21,"

 +13       SET DIC(0)="L"

           SET DIC("DR")=".02////"_BDMTXLI

           KILL DD,DO

 +14       IF '$DATA(^ATXAX(DA,21,0))

               SET ^ATXAX(DA,21,0)="^9002226.02101A"

 +15       DO FILE^DICN

 +16       IF '$DATA(^ATXAX(BDMTAXI,21,"B",BDMTXLI))

               WRITE !!,"adding ITEM failed."

               HANG 2

               GOTO ADD

 +17       GOTO ADDX

LABADD    ;

 +1        KILL DIC

 +2        SET DIC(0)="AEMQ"

           SET DIC="^LAB(60,"

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

           DO ^DIC

 +3        IF Y=-1

               GOTO ADDX

 +4        SET BDMTXLI=+Y

 +5        IF '$PIECE(^ATXLAB(BDMTAXI,0),U,11)

               IF $ORDER(^LAB(60,BDMTXLI,2,0))

                   SET BDMYN=""

                   Begin DoDot:1

 +6                    WRITE !!,"This lab test, ",$PIECE(^LAB(60,BDMTXLI,0),U),", is a panel test and the"

 +7                    WRITE !,"taxonomy ",$PIECE(^ATXLAB(BDMTAXI,0),U)," should not contain panel tests.",!

 +8                    SET DIR(0)="Y"

                       SET DIR("A")="Do you still want to add this lab test to this taxonomy"

                       SET DIR("B")="N"

                       KILL DA

                       DO ^DIR

                       KILL DIR

 +9                    IF $DATA(DIRUT)

                           QUIT 

 +10                   SET BDMYN=Y

                   End DoDot:1

                   IF 'BDMYN

                       GOTO ADDX

 +11       IF $DATA(^ATXLAB(BDMTAXI,21,"B",+Y))

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

               HANG 2

               GOTO ADD

 +12       SET DA=BDMTAXI

 +13       SET X=BDMTXLI

 +14       SET DA(1)=BDMTAXI

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

 +16       SET DIC(0)="L"

           KILL DD,DO

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

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

 +18       DO FILE^DICN

 +19       IF '$DATA(^ATXLAB(BDMTAXI,21,"B",BDMTXLI))

               WRITE !!,"adding lab test failed."

               HANG 2

               GOTO ADD

ADDX      ;

 +1        KILL DIC,DA,DR,BDMTXLI,DD,DO,BDMFILE

 +2        DO BACK

 +3        QUIT