BUDCUTXS.m

BUDCUTXS ; IHS/CMI/LAB - DISPLAY IND LISTS 16 Dec 2015 1:48 PM ;

 ;;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 15 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=$S(Y="LAB":$O(^ATXLAB("B",BUDX,0)),1:$O(^ATXAX("B",BUDX,0)))

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

 .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=$P(BUDTAX("IDX",Y,Y),U,1)

 S BUDTAXT=$P(BUDTAX("IDX",Y,Y),U,2)

 D EP^BUDCUTXL(BUDTAXI,BUDTAXT)

ADDX ;

 D BACK

 Q

LAB ;

 ;;BGP PQA CONTROLLER MEDS;;DRUG

 ;;BGP PQA SABA MEDS;;DRUG

 ;;BGP CMS SMOKING CESSATION MEDS;;DRUG

 ;;BGP PAP SMEAR TAX;;LAB

 ;;BGP HPV TESTS TAX;;LAB

 ;;BGP HIV TEST TAX;;LAB

 ;;DM AUDIT HGB A1C TAX;;LAB

 ;;BUD HEPATITIS B TESTS;;LAB

 ;;BUD HEPATITIS C TESTS;;LAB

 ;;BUD DIABETES MEDS TAX;;DRUG

 ;;BGP GPRA FOB TESTS;;LAB

 ;;BUD LIPID LOWERING MEDS;;DRUG

 ;;BUD ANTIPLATELET MEDS;;DRUG

 ;;DM AUDIT ASPIRIN DRUGS;;DRUG

 ;;BGP CD4 TAX;;LAB

 ;;BGP HIV VIRAL LOAD TAX;;LAB

 ;;BGP HEDIS ANTIDEPRESSANT MEDS;;DRUG

 ;;

BUDCUTXS  ; IHS/CMI/LAB - DISPLAY IND LISTS 16 Dec 2015 1:48 PM ;

 +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 15 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=$SELECT(Y="LAB":$ORDER(^ATXLAB("B",BUDX,0)),1:$ORDER(^ATXAX("B",BUDX,0)))

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

 +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=$PIECE(BUDTAX("IDX",Y,Y),U,1)

 +8        SET BUDTAXT=$PIECE(BUDTAX("IDX",Y,Y),U,2)

 +9        DO EP^BUDCUTXL(BUDTAXI,BUDTAXT)

ADDX      ;

 +1        DO BACK

 +2        QUIT 

LAB       ;

 +1       ;;BGP PQA CONTROLLER MEDS;;DRUG

 +2       ;;BGP PQA SABA MEDS;;DRUG

 +3       ;;BGP CMS SMOKING CESSATION MEDS;;DRUG

 +4       ;;BGP PAP SMEAR TAX;;LAB

 +5       ;;BGP HPV TESTS TAX;;LAB

 +6       ;;BGP HIV TEST TAX;;LAB

 +7       ;;DM AUDIT HGB A1C TAX;;LAB

 +8       ;;BUD HEPATITIS B TESTS;;LAB

 +9       ;;BUD HEPATITIS C TESTS;;LAB

 +10      ;;BUD DIABETES MEDS TAX;;DRUG

 +11      ;;BGP GPRA FOB TESTS;;LAB

 +12      ;;BUD LIPID LOWERING MEDS;;DRUG

 +13      ;;BUD ANTIPLATELET MEDS;;DRUG

 +14      ;;DM AUDIT ASPIRIN DRUGS;;DRUG

 +15      ;;BGP CD4 TAX;;LAB

 +16      ;;BGP HIV VIRAL LOAD TAX;;LAB

 +17      ;;BGP HEDIS ANTIDEPRESSANT MEDS;;DRUG

 +18      ;;