BGP5ETS.m

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

 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 ;; ;

EP ;EP - CALLED FROM OPTION

 D EN

 Q

EOJ ;EP

 D EN^XBVK("BGP")

 Q

 ;; ;

EN ;EP -- main entry point for 

 D EN^VALM("BGP 05 ELDER TAXONOMY UPDATE")

 D CLEAR^VALM1

 D FULL^VALM1

 W:$D(IOF) @IOF

 D EOJ

 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)="TAXONOMIES TO SUPPORT 2005 ELDER REPORTING"

 S VALMHDR(2)="* Update Taxonomies"

 Q

 ;

INIT ; -- init variables and list array

 K BGPTAX S BGPHIGH="",C=0

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

 .S BGPTAX(J,0)=J_")  "_BGPX,$E(BGPTAX(J,0),38)=$E(Y,1,30)

 .S I=$O(^ATXAX("B",BGPX,0))

 .S $E(BGPTAX(J,0),70)=$$VAL^XBDIQ1(9002226,I,.15)

 .S BGPTAX("IDX",J,J)=I_U_"T"

 .S C=C+1

 .Q

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

 .S J=J+1

 .S BGPTAX(J,0)=J_")  "_BGPX,$E(BGPTAX(J,0),38)=$E(Y,1,30),$E(BGPTAX(J,0),70)="LAB TEST"

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

 .S BGPTAX("IDX",J,J)=I_U_"L"

 .S C=C+1

 .Q

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

 D FULL^VALM1

 W !

 S DIR(0)="NO^1:"_BGPHIGH,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 BGPTAXI=$P(BGPTAX("IDX",Y,Y),U,1),BGPTAXT=$P(BGPTAX("IDX",Y,Y),U,2)

 I BGPTAXT="L" S BGPTAXN=$P(^ATXLAB(BGPTAXI,0),U)

 I BGPTAXT="T" S BGPTAXN=$P(^ATXAX(BGPTAXI,0),U)

 I BGPTAXT="L",$P(^ATXLAB(BGPTAXI,0),U,22) W !!,"The ",$P(^ATXLAB(BGPTAXI,0),U)," is READ ONLY.",!,"You can not update it." D PAUSE G ADDX

 I BGPTAXT="T",$P(^ATXAX(BGPTAXI,0),U,22) W !!,"The ",$P(^ATXAX(BGPTAXI,0),U)," is READ ONLY.",!,"You can not update it." D PAUSE G ADDX

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

 D EP^BGP5CTL(BGPTAXI)

ADDX ;

 D BACK

 Q

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

 W !

 S DIR(0)="NO^1:"_BGPHIGH,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 BGPTAXI=$P(BGPTAX("IDX",Y,Y),U,1),BGPTAXT=$P(BGPTAX("IDX",Y,Y),U,2)

 W !!!,$S(BGPTAXT="L":$P(^ATXLAB(BGPTAXI,0),U),1:$P(^ATXAX(BGPTAXI,0),U))

 W !!,"Items currently defined to this taxonomy:"

 I BGPTAXT="L" S X=0 F  S X=$O(^ATXLAB(BGPTAXI,21,"B",X)) Q:X=""  D

 .S Y=$P($G(^LAB(60,X,0)),U) W !?5,Y

 I BGPTAXT="T",'$P(^ATXAX(BGPTAXI,0),U,13) S X=0 F  S X=$O(^ATXAX(BGPTAXI,21,"B",X)) Q:X=""  D

 .W !?5,$$VAL^XBDIQ1($P(^ATXAX(BGPTAXI,0),U,15),X,.01)

 I BGPTAXT="T",$P(^ATXAX(BGPTAXI,0),U,13) S X=0 F  S X=$O(^ATXAX(BGPTAXI,21,"B",X)) Q:X=""  D

 .S H=0 F  S H=$O(^ATXAX(BGPTAXI,21,"B",X,H)) Q:H=""  D

 ..W !?5,$P(^ATXAX(BGPTAXI,21,H,0),U)_"-"_$P(^ATXAX(BGPTAXI,21,H,0),U,2)

 W !!

 K DIR S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR

DISPX ;

 D BACK

 Q

TAXS ;

 ;;BGP HEDIS OSTEOPOROSIS DRUGS;;Osteoporosis Medications Taxonomy

 ;;

LAB ;

 ;;DM AUDIT CHOLESTEROL TAX;;Cholesterol Taxonomy

 ;;BGP GPRA ESTIMATED GFR TAX;;Estimated GFR Taxonomy

 ;;BGP GPRA FOB TESTS;;Fecal Occult Blood Tests taxonomy

 ;;DM AUDIT HGB A1C TAX;;HGB A1C Lab Taxonomy

 ;;DM AUDIT HDL TAX;;HDL Lab Taxonomy

 ;;DM AUDIT LIPID PROFILE TAX;;Lipid Profile Lab Taxonomy

 ;;DM AUDIT LDL CHOLESTEROL TAX;;LDL Cholesterol Lab Taxonomy

 ;;DM AUDIT MICROALBUMINURIA TAX;;Microalbuminuia Lab Taxonomy

 ;;DM AUDIT TRIGLYCERIDE TAX;;Triglyceride Lab Taxonomy

 ;;DM AUDIT URINE PROTEIN TAX;;Urine Protein Lab Taxonomy

 ;;

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

 +1       ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 +2       ;; ;

EP        ;EP - CALLED FROM OPTION

 +1        DO EN

 +2        QUIT 

EOJ       ;EP

 +1        DO EN^XBVK("BGP")

 +2        QUIT 

 +3       ;; ;

EN        ;EP -- main entry point for 

 +1        DO EN^VALM("BGP 05 ELDER TAXONOMY UPDATE")

 +2        DO CLEAR^VALM1

 +3        DO FULL^VALM1

 +4        IF $DATA(IOF)

               WRITE @IOF

 +5        DO EOJ

 +6        QUIT 

 +7       ;

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)="TAXONOMIES TO SUPPORT 2005 ELDER REPORTING"

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

 +3        QUIT 

 +4       ;

INIT      ; -- init variables and list array

 +1        KILL BGPTAX

           SET BGPHIGH=""

           SET C=0

 +2        SET T="TAXS"

           FOR J=1:1

               SET Z=$TEXT(@T+J)

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

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

               IF BGPX=""

                   QUIT 

               Begin DoDot:1

 +3                SET BGPTAX(J,0)=J_")  "_BGPX

                   SET $EXTRACT(BGPTAX(J,0),38)=$EXTRACT(Y,1,30)

 +4                SET I=$ORDER(^ATXAX("B",BGPX,0))

 +5                SET $EXTRACT(BGPTAX(J,0),70)=$$VAL^XBDIQ1(9002226,I,.15)

 +6                SET BGPTAX("IDX",J,J)=I_U_"T"

 +7                SET C=C+1

 +8                QUIT 

               End DoDot:1

 +9        SET J=J-1

           SET T="LAB"

           FOR K=1:1

               SET Z=$TEXT(@T+K)

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

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

               IF BGPX=""

                   QUIT 

               Begin DoDot:1

 +10               SET J=J+1

 +11               SET BGPTAX(J,0)=J_")  "_BGPX

                   SET $EXTRACT(BGPTAX(J,0),38)=$EXTRACT(Y,1,30)

                   SET $EXTRACT(BGPTAX(J,0),70)="LAB TEST"

 +12               SET I=$ORDER(^ATXLAB("B",BGPX,0))

 +13               SET BGPTAX("IDX",J,J)=I_U_"L"

 +14               SET C=C+1

 +15               QUIT 

               End DoDot:1

 +16       SET (VALMCNT,BGPHIGH)=C

 +17       QUIT 

 +18      ;

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        DO FULL^VALM1

 +2        WRITE !

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

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

           SET BGPTAXT=$PIECE(BGPTAX("IDX",Y,Y),U,2)

 +8        IF BGPTAXT="L"

               SET BGPTAXN=$PIECE(^ATXLAB(BGPTAXI,0),U)

 +9        IF BGPTAXT="T"

               SET BGPTAXN=$PIECE(^ATXAX(BGPTAXI,0),U)

 +10       IF BGPTAXT="L"

               IF $PIECE(^ATXLAB(BGPTAXI,0),U,22)

                   WRITE !!,"The ",$PIECE(^ATXLAB(BGPTAXI,0),U)," is READ ONLY.",!,"You can not update it."

                   DO PAUSE

                   GOTO ADDX

 +11       IF BGPTAXT="T"

               IF $PIECE(^ATXAX(BGPTAXI,0),U,22)

                   WRITE !!,"The ",$PIECE(^ATXAX(BGPTAXI,0),U)," is READ ONLY.",!,"You can not update it."

                   DO PAUSE

                   GOTO ADDX

 +12       DO FULL^VALM1

           IF $DATA(IOF)

               WRITE @IOF

 +13       DO EP^BGP5CTL(BGPTAXI)

ADDX      ;

 +1        DO BACK

 +2        QUIT 

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

 +1        WRITE !

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

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

           SET BGPTAXT=$PIECE(BGPTAX("IDX",Y,Y),U,2)

 +8        WRITE !!!,$SELECT(BGPTAXT="L":$PIECE(^ATXLAB(BGPTAXI,0),U),1:$PIECE(^ATXAX(BGPTAXI,0),U))

 +9        WRITE !!,"Items currently defined to this taxonomy:"

 +10       IF BGPTAXT="L"

               SET X=0

               FOR 

                   SET X=$ORDER(^ATXLAB(BGPTAXI,21,"B",X))

                   IF X=""

                       QUIT 

                   Begin DoDot:1

 +11                   SET Y=$PIECE($GET(^LAB(60,X,0)),U)

                       WRITE !?5,Y

                   End DoDot:1

 +12       IF BGPTAXT="T"

               IF '$PIECE(^ATXAX(BGPTAXI,0),U,13)

                   SET X=0

                   FOR 

                       SET X=$ORDER(^ATXAX(BGPTAXI,21,"B",X))

                       IF X=""

                           QUIT 

                       Begin DoDot:1

 +13                       WRITE !?5,$$VAL^XBDIQ1($PIECE(^ATXAX(BGPTAXI,0),U,15),X,.01)

                       End DoDot:1

 +14       IF BGPTAXT="T"

               IF $PIECE(^ATXAX(BGPTAXI,0),U,13)

                   SET X=0

                   FOR 

                       SET X=$ORDER(^ATXAX(BGPTAXI,21,"B",X))

                       IF X=""

                           QUIT 

                       Begin DoDot:1

 +15                       SET H=0

                           FOR 

                               SET H=$ORDER(^ATXAX(BGPTAXI,21,"B",X,H))

                               IF H=""

                                   QUIT 

                               Begin DoDot:2

 +16                               WRITE !?5,$PIECE(^ATXAX(BGPTAXI,21,H,0),U)_"-"_$PIECE(^ATXAX(BGPTAXI,21,H,0),U,2)

                               End DoDot:2

                       End DoDot:1

 +17       WRITE !!

 +18       KILL DIR

           SET DIR(0)="E"

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

           DO ^DIR

           KILL DIR

DISPX     ;

 +1        DO BACK

 +2        QUIT 

TAXS      ;

 +1       ;;BGP HEDIS OSTEOPOROSIS DRUGS;;Osteoporosis Medications Taxonomy

 +2       ;;

LAB       ;

 +1       ;;DM AUDIT CHOLESTEROL TAX;;Cholesterol Taxonomy

 +2       ;;BGP GPRA ESTIMATED GFR TAX;;Estimated GFR Taxonomy

 +3       ;;BGP GPRA FOB TESTS;;Fecal Occult Blood Tests taxonomy

 +4       ;;DM AUDIT HGB A1C TAX;;HGB A1C Lab Taxonomy

 +5       ;;DM AUDIT HDL TAX;;HDL Lab Taxonomy

 +6       ;;DM AUDIT LIPID PROFILE TAX;;Lipid Profile Lab Taxonomy

 +7       ;;DM AUDIT LDL CHOLESTEROL TAX;;LDL Cholesterol Lab Taxonomy

 +8       ;;DM AUDIT MICROALBUMINURIA TAX;;Microalbuminuia Lab Taxonomy

 +9       ;;DM AUDIT TRIGLYCERIDE TAX;;Triglyceride Lab Taxonomy

 +10      ;;DM AUDIT URINE PROTEIN TAX;;Urine Protein Lab Taxonomy

 +11      ;;