BDMP9TL ; IHS/CMI/LAB - DISPLAY IND LISTS ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;; ;
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("BDMP9 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"
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)
.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)
.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)=+Y
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
BDMP9TL ; IHS/CMI/LAB - DISPLAY IND LISTS ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+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("BDMP9 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 QUIT
+3 ;
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)
+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)
+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)=+Y
+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
