APCLP6TL.m

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

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;; ;

EP(APCLTAXI) ;EP - CALLED FROM OPTION

 D EN

 Q

EOJ ;EP

 D EN^XBVK("APCL")

 Q

 ;; ;

EN ;EP -- main entry point for 

 D EN^VALM("APCLP6 TAXONOMY EDIT")

 D CLEAR^VALM1

 D FULL^VALM1

 W:$D(IOF) @IOF

 D EOJ

 Q

 ;

HDR ; -- header code

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

 Q

 ;

INIT ; -- init variables and list array

 I APCLTAXT="L" D LAB Q

 K APCLLAB S APCLHIGH="",C=0

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

 .S C=C+1

 .S APCLLABI=$P(^ATXAX(APCLTAXI,21,APCLX,0),U)

 .S APCLLAB(C,0)=C_")  "_$$VAL^XBDIQ1($P(^ATXAX(APCLTAXI,0),U,15),APCLLABI,.01)

 .S APCLLAB("IDX",C,C)=APCLLABI

 .Q

 S (VALMCNT,APCLHIGH)=C

 Q

LAB ;

 K APCLLAB S APCLHIGH="",C=0

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

 .S C=C+1

 .S APCLLABI=$P(^ATXLAB(APCLTAXI,21,APCLX,0),U)

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

 .S APCLLAB("IDX",C,C)=APCLLABI

 .Q

 S (VALMCNT,APCLHIGH)=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:"_APCLHIGH,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 APCLLABI=APCLLAB("IDX",Y,Y)

 ;sure

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

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

 I 'Y G REM

 I $D(DIRUT) G REMX

 D ^XBFMK

 I APCLTAXT="L" S DA(1)=APCLTAXI,DA=$O(^ATXLAB(APCLTAXI,21,"B",APCLLABI,0)),DIE="^ATXLAB("_APCLTAXI_",21,",DR=".01///@" D ^DIE

 I APCLTAXT="T" S DA(1)=APCLTAXI,DA=$O(^ATXAX(APCLTAXI,21,"B",APCLLABI,0)),DIE="^ATXAX("_APCLTAXI_",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 APCLTAXT="L" D LABADD G ADDX

 K DIC

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

 I Y=-1 G ADDX

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

 S DA=APCLTAXI

 S (X,APCLTXLI)=+Y

 S APCLFILE=$P(^ATXAX(APCLTAXI,0),U,15)

 S DA(1)=APCLTAXI

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

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

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

 D FILE^DICN

 I '$D(^ATXAX(APCLTAXI,21,"B",APCLTXLI)) 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

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

 S DA=APCLTAXI

 S (X,APCLTXLI)=+Y

 S DA(1)=APCLTAXI

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

ADDX ;

 K DIC,DA,DR,APCLTXLI,DD,DO,APCLFILE

 D BACK

 Q

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

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;; ;

EP(APCLTAXI) ;EP - CALLED FROM OPTION

 +1        DO EN

 +2        QUIT 

EOJ       ;EP

 +1        DO EN^XBVK("APCL")

 +2        QUIT 

 +3       ;; ;

EN        ;EP -- main entry point for 

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

 +2        QUIT 

 +3       ;

INIT      ; -- init variables and list array

 +1        IF APCLTAXT="L"

               DO LAB

               QUIT 

 +2        KILL APCLLAB

           SET APCLHIGH=""

           SET C=0

 +3        SET APCLX=0

           FOR 

               SET APCLX=$ORDER(^ATXAX(APCLTAXI,21,APCLX))

               IF APCLX'=+APCLX

                   QUIT 

               Begin DoDot:1

 +4                SET C=C+1

 +5                SET APCLLABI=$PIECE(^ATXAX(APCLTAXI,21,APCLX,0),U)

 +6                SET APCLLAB(C,0)=C_")  "_$$VAL^XBDIQ1($PIECE(^ATXAX(APCLTAXI,0),U,15),APCLLABI,.01)

 +7                SET APCLLAB("IDX",C,C)=APCLLABI

 +8                QUIT 

               End DoDot:1

 +9        SET (VALMCNT,APCLHIGH)=C

 +10       QUIT 

LAB       ;

 +1        KILL APCLLAB

           SET APCLHIGH=""

           SET C=0

 +2        SET APCLX=0

           FOR 

               SET APCLX=$ORDER(^ATXLAB(APCLTAXI,21,APCLX))

               IF APCLX'=+APCLX

                   QUIT 

               Begin DoDot:1

 +3                SET C=C+1

 +4                SET APCLLABI=$PIECE(^ATXLAB(APCLTAXI,21,APCLX,0),U)

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

 +6                SET APCLLAB("IDX",C,C)=APCLLABI

 +7                QUIT 

               End DoDot:1

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

           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 APCLLABI=APCLLAB("IDX",Y,Y)

 +7       ;sure

 +8        IF APCLTAXT="L"

               KILL DIR

               SET DIR(0)="Y"

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

               SET DIR("B")="N"

               KILL DA

               DO ^DIR

               KILL DIR

 +9        IF APCLTAXT="T"

               KILL DIR

               SET DIR(0)="Y"

               SET DIR("A")="Are you sure you want to remove the "_$$VAL^XBDIQ1($PIECE(^ATXAX(APCLTAXI,0),U,15),APCLLABI,.01)_" "_$$VAL^XBDIQ1(9002226,APCLTAXI,.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 APCLTAXT="L"

               SET DA(1)=APCLTAXI

               SET DA=$ORDER(^ATXLAB(APCLTAXI,21,"B",APCLLABI,0))

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

               SET DR=".01///@"

               DO ^DIE

 +14       IF APCLTAXT="T"

               SET DA(1)=APCLTAXI

               SET DA=$ORDER(^ATXAX(APCLTAXI,21,"B",APCLLABI,0))

               SET DIE="^ATXAX("_APCLTAXI_",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 APCLTAXT="L"

               DO LABADD

               GOTO ADDX

 +4        KILL DIC

 +5        SET DIC(0)="AEMQ"

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

           DO ^DIC

 +6        IF Y=-1

               GOTO ADDX

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

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

               HANG 2

               GOTO ADD

 +8        SET DA=APCLTAXI

 +9        SET (X,APCLTXLI)=+Y

 +10       SET APCLFILE=$PIECE(^ATXAX(APCLTAXI,0),U,15)

 +11       SET DA(1)=APCLTAXI

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

 +13       SET DIC(0)="L"

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

           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(APCLTAXI,21,"B",APCLTXLI))

               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        IF $DATA(^ATXLAB(APCLTAXI,21,"B",+Y))

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

               HANG 2

               GOTO ADD

 +5        SET DA=APCLTAXI

 +6        SET (X,APCLTXLI)=+Y

 +7        SET DA(1)=APCLTAXI

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

 +9        SET DIC(0)="L"

           KILL DD,DO

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

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

 +11       DO FILE^DICN

 +12       IF '$DATA(^ATXLAB(APCLTAXI,21,"B",APCLTXLI))

               WRITE !!,"adding lab test failed."

               HANG 2

               GOTO ADD

ADDX      ;

 +1        KILL DIC,DA,DR,APCLTXLI,DD,DO,APCLFILE

 +2        DO BACK

 +3        QUIT