BUD6UTXS.m

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

 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50

 ;; ;

EP ;EP - CALLED FROM OPTION

 D EN

 Q

EOJ ;EP

 D EN^XBVK("BUD")

 Q

 ;; ;

EN ;EP -- main entry point for 

 D EN^VALM("BUD 06 TAXONOMY UPDATE")

 D CLEAR^VALM1

 D FULL^VALM1

 W:$D(IOF) @IOF

 D EOJ

 Q

 ;

HDR ; -- header code

 S VALMHDR(1)="TAXONOMIES TO SUPPORT UDS REPORTING"

 S VALMHDR(2)="* Update Taxonomies"

 Q

 ;

INIT ; -- init variables and list array

 K BUDTAX S BUDHIGH="",C=0

 S T="LAB" F J=1:1 S Z=$T(@T+J),BUDX=$P(Z,";;",2),Y=$P(Z,";;",3) Q:BUDX=""  D

 .S BUDTAX(J,0)=J_")  "_BUDX,$E(BUDTAX(J,0),40)=Y

 .S I=$O(^ATXLAB("B",BUDX,0))

 .S BUDTAX("IDX",J,J)=I

 .S C=C+1

 .Q

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

 ;

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

 W !

 S DIR(0)="NO^1:"_BUDHIGH,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

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

 S BUDTAXI=BUDTAX("IDX",Y,Y)

 D EP^BUD6UTXL(BUDTAXI)

ADDX ;

 D BACK

 Q

LAB ;

 ;;BGP PAP SMEAR TAX

 ;;BGP HIV TEST TAX

 ;;

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

 +1       ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50

 +2       ;; ;

EP        ;EP - CALLED FROM OPTION

 +1        DO EN

 +2        QUIT 

EOJ       ;EP

 +1        DO EN^XBVK("BUD")

 +2        QUIT 

 +3       ;; ;

EN        ;EP -- main entry point for 

 +1        DO EN^VALM("BUD 06 TAXONOMY UPDATE")

 +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)="TAXONOMIES TO SUPPORT UDS REPORTING"

 +2        SET VALMHDR(2)="* Update Taxonomies"

 +3        QUIT 

 +4       ;

INIT      ; -- init variables and list array

 +1        KILL BUDTAX

           SET BUDHIGH=""

           SET C=0

 +2        SET T="LAB"

           FOR J=1:1

               SET Z=$TEXT(@T+J)

               SET BUDX=$PIECE(Z,";;",2)

               SET Y=$PIECE(Z,";;",3)

               IF BUDX=""

                   QUIT 

               Begin DoDot:1

 +3                SET BUDTAX(J,0)=J_")  "_BUDX

                   SET $EXTRACT(BUDTAX(J,0),40)=Y

 +4                SET I=$ORDER(^ATXLAB("B",BUDX,0))

 +5                SET BUDTAX("IDX",J,J)=I

 +6                SET C=C+1

 +7                QUIT 

               End DoDot:1

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

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

 +1        WRITE !

 +2        SET DIR(0)="NO^1:"_BUDHIGH

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

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF Y=""

               WRITE !,"No taxonomy selected."

               GOTO ADDX

 +5        IF $DATA(DIRUT)

               WRITE !,"No taxonomy selected."

               GOTO ADDX

 +6        DO FULL^VALM1

           IF $DATA(IOF)

               WRITE @IOF

 +7        SET BUDTAXI=BUDTAX("IDX",Y,Y)

 +8        DO EP^BUD6UTXL(BUDTAXI)

ADDX      ;

 +1        DO BACK

 +2        QUIT 

LAB       ;

 +1       ;;BGP PAP SMEAR TAX

 +2       ;;BGP HIV TEST TAX

 +3       ;;