BNITAXT.m

BNITAXT ; IHS/CMI/LAB - DISPLAY TAX ;

 ;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006

 ;; ;

EP ;EP - CALLED FROM OPTION

 S BNITAXT=$O(^ATXTYPE("B","COMMUNITY",0)),BNIFILE=9999999.05,BNITAXF=9999999.05

 D EN

 Q

 ;; ;

EN ;EP -- main entry point for 

 D EN^VALM("BNI TAXONOMY GENERIC LIST")

 D CLEAR^VALM1

 D FULL^VALM1

 W:$D(IOF) @IOF

 K BNILIST,J,C

 D ^XBFMK

 Q

 ;

PAUSE ;EP

 Q:$E(IOST)'="C"!(IO'=IO(0))

 W ! S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q

HDR ; -- header code

 S VALMHDR(1)="ADD OR EDIT "_$P(^ATXTYPE(BNITAXT,0),U)_" TAXONOMIES"

 S VALMHDR(2)="TAXONOMY NAME",$E(VALMHDR(2),38)="DESCRIPTION",$E(VALMHDR(2),70)="FILE"

 Q

 ;

INIT ; -- init variables and list array

 I BNIFILE=60 D LABINIT Q

 K BNILIST S BNIHIGH="",C=0

 S J=0 F  S J=$O(^ATXAX(J)) Q:J'=+J  D

 .I $P(^ATXAX(J,0),U,15)'=BNIFILE Q

 .S C=C+1

 .S D=$P(^ATXAX(J,0),U,2)

 .S BNILIST(C,0)=C_")  "_$P(^ATXAX(J,0),U),$E(BNILIST(C,0),38)=D,$E(BNILIST(C,0),70)=BNIFILE

 .S BNILIST("IDX",C,C)=J

 .Q

 S (VALMCNT,BNIHIGH)=C

 Q

LABINIT ;

 K BNILIST S BNIHIGH="",C=0

 S J=0 F  S J=$O(^ATXLAB(J)) Q:J'=+J  D

 .S C=C+1

 .S D=$P(^ATXLAB(J,0),U,2)

 .S BNILIST(C,0)=C_")  "_$P(^ATXLAB(J,0),U),$E(BNILIST(C,0),38)=D,$E(BNILIST(C,0),70)=BNIFILE

 .S BNILIST("IDX",C,C)=J

 .Q

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

 ;

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

 D FULL^VALM1

 W !

 S DIR(0)="NO^1:"_BNIHIGH,DIR("A")="Which Taxonomy"

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

 I Y="" W !,"No taxonomy selected." G ADDX

 I $D(DIRUT) W !,"No taxonomy selected." G ADDX

 S BNITAXI=$P(BNILIST("IDX",Y,Y),U,1),BNITAXN=$S(BNIFILE=60:$P(^ATXLAB(BNITAXI,0),U),1:$P(^ATXAX(BNITAXI,0),U))

 D FULL^VALM1 W:$D(IOF) @IOF

 D EP^BNITAXE

ADDX ;

 D BACK

 Q

ADDNEW ;EP  add new taxonomy of this type

 I BNIFILE=60 D LABADD G ADDNEWX

 S ATXADD=1,ATXFLG=1

 K DIC

 S DIC="^ATXAX(",DIC("DR")=".02",DIC(0)="AEMLQ" D ^DIC K DIC

 I Y=-1 G ADDNEWX

 S BNITAXI=+Y

 S DA=BNITAXI,DIE="^ATXAX("

 S DR=".09////"_DT_";.12////"_$P(^ATXTYPE(BNITAXT,0),U,3)_";.13////"_$S(BNIFILE=80:1,BNIFILE=80.1:1,BNIFILE=81:1,1:"")_";.15////"_$P(^ATXTYPE(BNITAXT,0),U,2)

 D ^DIE K DIE,DA,DR

 I $D(Y) W !!,"error creating taxonomy........" S DA=BNITAXI,DIK="^ATXAX(" D ^DIK K DIK,DA D PAUSE G ADDNEWX

 S BNITAXN=$P(^ATXAX(BNITAXI,0),U)

 D EP^BNITAXE

ADDNEWX ;

 D BACK

 Q

LABADD ;

 K DIC

 S DIC="^ATXLAB(",DIC("DR")=".02",DIC(0)="AEMLQ" D ^DIC K DIC

 I Y=-1 G ADDNEWX

 S BNITAXI=+Y

 S DA=BNITAXI,DIE="^ATXLAB("

 S DR=".09////"_DT

 D ^DIE K DIE,DA,DR

 I $D(Y) W !!,"error creating taxonomy........" S DA=BNITAXI,DIK="^ATXAX(" D ^DIK K DIK,DA D PAUSE G ADDNEWX

 S BNITAXN=$P(^ATXLAB(BNITAXI,0),U)

 D EP^BNITAXE

 G ADDNEWX

BNITAXT   ; IHS/CMI/LAB - DISPLAY TAX ;

 +1       ;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006

 +2       ;; ;

EP        ;EP - CALLED FROM OPTION

 +1        SET BNITAXT=$ORDER(^ATXTYPE("B","COMMUNITY",0))

           SET BNIFILE=9999999.05

           SET BNITAXF=9999999.05

 +2        DO EN

 +3        QUIT 

 +4       ;; ;

EN        ;EP -- main entry point for 

 +1        DO EN^VALM("BNI TAXONOMY GENERIC LIST")

 +2        DO CLEAR^VALM1

 +3        DO FULL^VALM1

 +4        IF $DATA(IOF)

               WRITE @IOF

 +5        KILL BNILIST,J,C

 +6        DO ^XBFMK

 +7        QUIT 

 +8       ;

PAUSE     ;EP

 +1        IF $EXTRACT(IOST)'="C"!(IO'=IO(0))

               QUIT 

 +2        WRITE !

           SET DIR(0)="EO"

           SET DIR("A")="Press enter to continue...."

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        QUIT 

HDR       ; -- header code

 +1        SET VALMHDR(1)="ADD OR EDIT "_$PIECE(^ATXTYPE(BNITAXT,0),U)_" TAXONOMIES"

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

           SET $EXTRACT(VALMHDR(2),38)="DESCRIPTION"

           SET $EXTRACT(VALMHDR(2),70)="FILE"

 +3        QUIT 

 +4       ;

INIT      ; -- init variables and list array

 +1        IF BNIFILE=60

               DO LABINIT

               QUIT 

 +2        KILL BNILIST

           SET BNIHIGH=""

           SET C=0

 +3        SET J=0

           FOR 

               SET J=$ORDER(^ATXAX(J))

               IF J'=+J

                   QUIT 

               Begin DoDot:1

 +4                IF $PIECE(^ATXAX(J,0),U,15)'=BNIFILE

                       QUIT 

 +5                SET C=C+1

 +6                SET D=$PIECE(^ATXAX(J,0),U,2)

 +7                SET BNILIST(C,0)=C_")  "_$PIECE(^ATXAX(J,0),U)

                   SET $EXTRACT(BNILIST(C,0),38)=D

                   SET $EXTRACT(BNILIST(C,0),70)=BNIFILE

 +8                SET BNILIST("IDX",C,C)=J

 +9                QUIT 

               End DoDot:1

 +10       SET (VALMCNT,BNIHIGH)=C

 +11       QUIT 

LABINIT   ;

 +1        KILL BNILIST

           SET BNIHIGH=""

           SET C=0

 +2        SET J=0

           FOR 

               SET J=$ORDER(^ATXLAB(J))

               IF J'=+J

                   QUIT 

               Begin DoDot:1

 +3                SET C=C+1

 +4                SET D=$PIECE(^ATXLAB(J,0),U,2)

 +5                SET BNILIST(C,0)=C_")  "_$PIECE(^ATXLAB(J,0),U)

                   SET $EXTRACT(BNILIST(C,0),38)=D

                   SET $EXTRACT(BNILIST(C,0),70)=BNIFILE

 +6                SET BNILIST("IDX",C,C)=J

 +7                QUIT 

               End DoDot:1

 +8        SET (VALMCNT,BNIHIGH)=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       ;

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

 +1        DO FULL^VALM1

 +2        WRITE !

 +3        SET DIR(0)="NO^1:"_BNIHIGH

           SET DIR("A")="Which Taxonomy"

 +4        DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +5        IF Y=""

               WRITE !,"No taxonomy selected."

               GOTO ADDX

 +6        IF $DATA(DIRUT)

               WRITE !,"No taxonomy selected."

               GOTO ADDX

 +7        SET BNITAXI=$PIECE(BNILIST("IDX",Y,Y),U,1)

           SET BNITAXN=$SELECT(BNIFILE=60:$PIECE(^ATXLAB(BNITAXI,0),U),1:$PIECE(^ATXAX(BNITAXI,0),U))

 +8        DO FULL^VALM1

           IF $DATA(IOF)

               WRITE @IOF

 +9        DO EP^BNITAXE

ADDX      ;

 +1        DO BACK

 +2        QUIT 

ADDNEW    ;EP  add new taxonomy of this type

 +1        IF BNIFILE=60

               DO LABADD

               GOTO ADDNEWX

 +2        SET ATXADD=1

           SET ATXFLG=1

 +3        KILL DIC

 +4        SET DIC="^ATXAX("

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

           SET DIC(0)="AEMLQ"

           DO ^DIC

           KILL DIC

 +5        IF Y=-1

               GOTO ADDNEWX

 +6        SET BNITAXI=+Y

 +7        SET DA=BNITAXI

           SET DIE="^ATXAX("

 +8        SET DR=".09////"_DT_";.12////"_$PIECE(^ATXTYPE(BNITAXT,0),U,3)_";.13////"_$SELECT(BNIFILE=80:1,BNIFILE=80.1:1,BNIFILE=81:1,1:"")_";.15////"_$PIECE(^ATXTYPE(BNITAXT,0),U,2)

 +9        DO ^DIE

           KILL DIE,DA,DR

 +10       IF $DATA(Y)

               WRITE !!,"error creating taxonomy........"

               SET DA=BNITAXI

               SET DIK="^ATXAX("

               DO ^DIK

               KILL DIK,DA

               DO PAUSE

               GOTO ADDNEWX

 +11       SET BNITAXN=$PIECE(^ATXAX(BNITAXI,0),U)

 +12       DO EP^BNITAXE

ADDNEWX   ;

 +1        DO BACK

 +2        QUIT 

LABADD    ;

 +1        KILL DIC

 +2        SET DIC="^ATXLAB("

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

           SET DIC(0)="AEMLQ"

           DO ^DIC

           KILL DIC

 +3        IF Y=-1

               GOTO ADDNEWX

 +4        SET BNITAXI=+Y

 +5        SET DA=BNITAXI

           SET DIE="^ATXLAB("

 +6        SET DR=".09////"_DT

 +7        DO ^DIE

           KILL DIE,DA,DR

 +8        IF $DATA(Y)

               WRITE !!,"error creating taxonomy........"

               SET DA=BNITAXI

               SET DIK="^ATXAX("

               DO ^DIK

               KILL DIK,DA

               DO PAUSE

               GOTO ADDNEWX

 +9        SET BNITAXN=$PIECE(^ATXLAB(BNITAXI,0),U)

 +10       DO EP^BNITAXE

 +11       GOTO ADDNEWX