BGP9CTS ; IHS/CMI/LAB - DISPLAY IND LISTS ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;; ;
EP ;EP - CALLED FROM OPTION
I BGPRPTTT="C" S BGPRPTT2="CMS",BGPRPTT1=5
I BGPRPTTT="E" S BGPRPTT2="ELDER REPORT",BGPRPTT1=4
I BGPRPTTT="N" S BGPRPTT2="NATIONAL GPRA REPORT",BGPRPTT1=1
I BGPRPTTT="A" S BGPRPTT2="ALL CRS REPORTS",BGPRPTT1=9
I BGPRPTTT="H" S BGPRPTT2="HEDIS",BGPRPTT1=3
I BGPRPTTT="O" S BGPRPTT2="OTHER NATIONAL MEASURES",BGPRPTT1=7
I BGPRPTTT="X" S BGPRPTT2="EXECUTIVE ORDER TRANSPARENCY QUALITY MEASURES",BGPRPTT1=8
D EN
Q
EOJ ;EP
D EN^XBVK("BGP")
Q
;; ;
EN ;EP -- main entry point for
D EN^VALM("BGP 09 CRS 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 2009 "_BGPRPTT2_" REPORTING"
Q
;
INIT ;EP -- init variables and list array
I '$G(BGPRPTT1) S BGPRPTT1=9
K BGPTAX S BGPHIGH="",C=0,J=0
S BGPT="" F S BGPT=$O(^BGPTAXN("B",BGPT)) Q:BGPT="" D
.S BGPY=$O(^BGPTAXN("B",BGPT,0))
.Q:$P(^BGPTAXN(BGPY,0),U,4)'=1
.I BGPRPTT1=9 Q:'$O(^BGPTAXN(BGPY,12,0))
.I BGPRPTT1'=9,'$D(^BGPTAXN(BGPY,12,"B",BGPRPTT1)) Q
.S BGPTYPE=$P(^BGPTAXN(BGPY,0),U,2),BGPDESC=$G(^BGPTAXN(BGPY,11,1,0)),BGPEDIT=$P(^BGPTAXN(BGPY,0),U,4),J=J+1
.I BGPTYPE'="L" D
..S I=$O(^ATXAX("B",BGPT,0))
.I BGPTYPE="L" D
..S I=$O(^ATXLAB("B",BGPT,0))
.S BGPTAX(J,0)=J_") "_BGPT ;,$E(BGPTAX(J,0),38)=$S(BGPEDIT:"***",1:"") ;,$E(BGPTAX(J,0),70)=$S('BGPEDIT:"VIEW ONLY/UNEDITABLE",1:"")
.S $E(BGPTAX(J,0),38)=$$VAL^XBDIQ1(90536.08,BGPY,.02)
.S $E(BGPTAX(J,0),50)=BGPDESC
.S BGPTAX("IDX",J,J)=I_U_$S(BGPTYPE'="L":"T",1:"L")_U_BGPY
.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 !
I '$D(^XUSEC("BGPZ TAXONOMY EDIT",DUZ)) W !!,"You do not have the security access to edit a taxonomy.",!,"Please see your supervisor or program manager.",! D PAUSE G ADDX
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),BGPTAXN=$P(BGPTAX("IDX",Y,Y),U,3),BGPEDIT=$P(^BGPTAXN(BGPTAXN,0),U,4)
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)!('BGPEDIT) W !!,"The ",$P(^ATXLAB(BGPTAXI,0),U)," is VIEW ONLY.",!,"You can not update it." D PAUSE G ADDX
I BGPTAXT="T",$P(^ATXAX(BGPTAXI,0),U,22)!('BGPEDIT) W !!,"The ",$P(^ATXAX(BGPTAXI,0),U)," is VIEW ONLY.",!,"You can not update it." D PAUSE G ADDX
D FULL^VALM1 W:$D(IOF) @IOF
D EP^BGP9CTL(BGPTAXI)
ADDX ;
D BACK
Q
DISP ;EP
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 DISPX
I $D(DIRUT) W !,"No taxonomy selected." G DISPX
S BGPFIEN=$P(BGPTAX("IDX",Y,Y),U,3)
S BGPSEL=Y
S BGPTIEN=$P(BGPTAX("IDX",Y,Y),U,1)
S BGPTYPE=$P(BGPTAX("IDX",Y,Y),U,2)
S BGPFIEN=$P(BGPTAX("IDX",Y,Y),U,3)
D FULL^VALM1 W:$D(IOF) @IOF
D EP^BGP9XTV1(BGPTIEN,BGPTYPE,BGPFIEN)
DISPX ;
D BACK
Q
DISP1 ;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 DISPX
I $D(DIRUT) W !,"No taxonomy selected." G DISPX
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
DISP1X ;
D BACK
Q
BGP9CTS ; IHS/CMI/LAB - DISPLAY IND LISTS ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+2 ;; ;
EP ;EP - CALLED FROM OPTION
+1 IF BGPRPTTT="C"
SET BGPRPTT2="CMS"
SET BGPRPTT1=5
+2 IF BGPRPTTT="E"
SET BGPRPTT2="ELDER REPORT"
SET BGPRPTT1=4
+3 IF BGPRPTTT="N"
SET BGPRPTT2="NATIONAL GPRA REPORT"
SET BGPRPTT1=1
+4 IF BGPRPTTT="A"
SET BGPRPTT2="ALL CRS REPORTS"
SET BGPRPTT1=9
+5 IF BGPRPTTT="H"
SET BGPRPTT2="HEDIS"
SET BGPRPTT1=3
+6 IF BGPRPTTT="O"
SET BGPRPTT2="OTHER NATIONAL MEASURES"
SET BGPRPTT1=7
+7 IF BGPRPTTT="X"
SET BGPRPTT2="EXECUTIVE ORDER TRANSPARENCY QUALITY MEASURES"
SET BGPRPTT1=8
+8 DO EN
+9 QUIT
EOJ ;EP
+1 DO EN^XBVK("BGP")
+2 QUIT
+3 ;; ;
EN ;EP -- main entry point for
+1 DO EN^VALM("BGP 09 CRS 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 2009 "_BGPRPTT2_" REPORTING"
+2 QUIT
+3 ;
INIT ;EP -- init variables and list array
+1 IF '$GET(BGPRPTT1)
SET BGPRPTT1=9
+2 KILL BGPTAX
SET BGPHIGH=""
SET C=0
SET J=0
+3 SET BGPT=""
FOR
SET BGPT=$ORDER(^BGPTAXN("B",BGPT))
IF BGPT=""
QUIT
Begin DoDot:1
+4 SET BGPY=$ORDER(^BGPTAXN("B",BGPT,0))
+5 IF $PIECE(^BGPTAXN(BGPY,0),U,4)'=1
QUIT
+6 IF BGPRPTT1=9
IF '$ORDER(^BGPTAXN(BGPY,12,0))
QUIT
+7 IF BGPRPTT1'=9
IF '$DATA(^BGPTAXN(BGPY,12,"B",BGPRPTT1))
QUIT
+8 SET BGPTYPE=$PIECE(^BGPTAXN(BGPY,0),U,2)
SET BGPDESC=$GET(^BGPTAXN(BGPY,11,1,0))
SET BGPEDIT=$PIECE(^BGPTAXN(BGPY,0),U,4)
SET J=J+1
+9 IF BGPTYPE'="L"
Begin DoDot:2
+10 SET I=$ORDER(^ATXAX("B",BGPT,0))
End DoDot:2
+11 IF BGPTYPE="L"
Begin DoDot:2
+12 SET I=$ORDER(^ATXLAB("B",BGPT,0))
End DoDot:2
+13 ;,$E(BGPTAX(J,0),38)=$S(BGPEDIT:"***",1:"") ;,$E(BGPTAX(J,0),70)=$S('BGPEDIT:"VIEW ONLY/UNEDITABLE",1:"")
SET BGPTAX(J,0)=J_") "_BGPT
+14 SET $EXTRACT(BGPTAX(J,0),38)=$$VAL^XBDIQ1(90536.08,BGPY,.02)
+15 SET $EXTRACT(BGPTAX(J,0),50)=BGPDESC
+16 SET BGPTAX("IDX",J,J)=I_U_$SELECT(BGPTYPE'="L":"T",1:"L")_U_BGPY
+17 SET C=C+1
+18 QUIT
End DoDot:1
+19 SET (VALMCNT,BGPHIGH)=C
+20 QUIT
+21 ;
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 IF '$DATA(^XUSEC("BGPZ TAXONOMY EDIT",DUZ))
WRITE !!,"You do not have the security access to edit a taxonomy.",!,"Please see your supervisor or program manager.",!
DO PAUSE
GOTO ADDX
+4 SET DIR(0)="NO^1:"_BGPHIGH
SET DIR("A")="Which Taxonomy"
+5 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+6 IF Y=""
WRITE !,"No taxonomy selected."
GOTO ADDX
+7 IF $DATA(DIRUT)
WRITE !,"No taxonomy selected."
GOTO ADDX
+8 SET BGPTAXI=$PIECE(BGPTAX("IDX",Y,Y),U,1)
SET BGPTAXT=$PIECE(BGPTAX("IDX",Y,Y),U,2)
SET BGPTAXN=$PIECE(BGPTAX("IDX",Y,Y),U,3)
SET BGPEDIT=$PIECE(^BGPTAXN(BGPTAXN,0),U,4)
+9 IF BGPTAXT="L"
SET BGPTAXN=$PIECE(^ATXLAB(BGPTAXI,0),U)
+10 IF BGPTAXT="T"
SET BGPTAXN=$PIECE(^ATXAX(BGPTAXI,0),U)
+11 IF BGPTAXT="L"
IF $PIECE(^ATXLAB(BGPTAXI,0),U,22)!('BGPEDIT)
WRITE !!,"The ",$PIECE(^ATXLAB(BGPTAXI,0),U)," is VIEW ONLY.",!,"You can not update it."
DO PAUSE
GOTO ADDX
+12 IF BGPTAXT="T"
IF $PIECE(^ATXAX(BGPTAXI,0),U,22)!('BGPEDIT)
WRITE !!,"The ",$PIECE(^ATXAX(BGPTAXI,0),U)," is VIEW ONLY.",!,"You can not update it."
DO PAUSE
GOTO ADDX
+13 DO FULL^VALM1
IF $DATA(IOF)
WRITE @IOF
+14 DO EP^BGP9CTL(BGPTAXI)
ADDX ;
+1 DO BACK
+2 QUIT
DISP ;EP
+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 DISPX
+5 IF $DATA(DIRUT)
WRITE !,"No taxonomy selected."
GOTO DISPX
+6 SET BGPFIEN=$PIECE(BGPTAX("IDX",Y,Y),U,3)
+7 SET BGPSEL=Y
+8 SET BGPTIEN=$PIECE(BGPTAX("IDX",Y,Y),U,1)
+9 SET BGPTYPE=$PIECE(BGPTAX("IDX",Y,Y),U,2)
+10 SET BGPFIEN=$PIECE(BGPTAX("IDX",Y,Y),U,3)
+11 DO FULL^VALM1
IF $DATA(IOF)
WRITE @IOF
+12 DO EP^BGP9XTV1(BGPTIEN,BGPTYPE,BGPFIEN)
DISPX ;
+1 DO BACK
+2 QUIT
DISP1 ;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 DISPX
+5 IF $DATA(DIRUT)
WRITE !,"No taxonomy selected."
GOTO DISPX
+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
DISP1X ;
+1 DO BACK
+2 QUIT
