BGP8XTV ; IHS/CMI/LAB - DISPLAY IND LISTS 15 Dec 2010 9:42 AM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;; ;
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 18 TAXONOMY VIEW")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
D EOJ
Q
;
HDR ; -- header code
S VALMHDR(1)="VIEW CRS TAXONOMIES"
Q
;
INIT ;EP -- init variables and list array
K BGPTAX S BGPHIGH="",C=0,J=0
S BGPT=""
F S BGPT=$O(^BGPTAXR("B",BGPT)) Q:BGPT="" D
.S BGPY=$O(^BGPTAXR("B",BGPT,0))
.Q:'$O(^BGPTAXR(BGPY,12,0))
.S BGPTYPE=$P(^BGPTAXR(BGPY,0),U,2),BGPDESC=$G(^BGPTAXR(BGPY,11,1,0)),BGPEDIT=$P(^BGPTAXR(BGPY,0),U,4)
.I BGPTYPE'="L" D Q:'I
..S I=$O(^ATXAX("B",BGPT,0))
.I BGPTYPE="L" D Q:'I
..S I=$O(^ATXLAB("B",BGPT,0))
.S J=J+1
SET .;
.S BGPTAX(J,0)=J_") "_BGPT
.S $E(BGPTAX(J,0),38)=$$VAL^XBDIQ1(90560.08,BGPY,.02)
.S $E(BGPTAX(J,0),55)=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
;
;
K BGPTAX S BGPHIGH="",C=0
S T="",J=0,C=0 F S T=$O(^BGPTAXR("B",T)) Q:T="" D
.S Y=0 F S Y=$O(^BGPTAXR("B",T,Y)) Q:Y'=+Y D
..S N=^BGPTAXR(Y,0)
..S Z=$P(N,U,2) ;TYPE
..I Z="L" S BGPT=$O(^ATXLAB("B",T,0))
..I Z'="L" S BGPT=$O(^ATXAX("B",T,0))
..I Z="" Q
..S J=J+1
..S BGPTAX(J,0)=J_") "_T,$E(BGPTAX(J,0),39)=$$VAL^XBDIQ1(90560.08,Y,.02) D
...S A="",B=0 F S B=$O(^BGPTAXR(Y,12,B)) Q:B'=+B S R=$P(^BGPTAXR(Y,12,B,0),U) S:A]"" A=A_";" S A=A_$S(R=1:"National GPRA",R=2:"Local CRS",R=3:"HEDIS",R=4:"ELDER",R=5:"CMS",1:"")
...S $E(BGPTAX(J,0),60)=A
..S BGPTAX("IDX",J,J)=BGPT_U_Z_U_Y
..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
;
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 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)
;D FULL^VALM1 W:$D(IOF) @IOF
D EP^BGP8XTV1(BGPTIEN,BGPTYPE,BGPFIEN)
DISPX ;
D BACK
Q
BGP8XTV ; IHS/CMI/LAB - DISPLAY IND LISTS 15 Dec 2010 9:42 AM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+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 18 TAXONOMY VIEW")
+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)="VIEW CRS TAXONOMIES"
+2 QUIT
+3 ;
INIT ;EP -- init variables and list array
+1 KILL BGPTAX
SET BGPHIGH=""
SET C=0
SET J=0
+2 SET BGPT=""
+3 FOR
SET BGPT=$ORDER(^BGPTAXR("B",BGPT))
IF BGPT=""
QUIT
Begin DoDot:1
+4 SET BGPY=$ORDER(^BGPTAXR("B",BGPT,0))
+5 IF '$ORDER(^BGPTAXR(BGPY,12,0))
QUIT
+6 SET BGPTYPE=$PIECE(^BGPTAXR(BGPY,0),U,2)
SET BGPDESC=$GET(^BGPTAXR(BGPY,11,1,0))
SET BGPEDIT=$PIECE(^BGPTAXR(BGPY,0),U,4)
+7 IF BGPTYPE'="L"
Begin DoDot:2
+8 SET I=$ORDER(^ATXAX("B",BGPT,0))
End DoDot:2
IF 'I
QUIT
+9 IF BGPTYPE="L"
Begin DoDot:2
+10 SET I=$ORDER(^ATXLAB("B",BGPT,0))
End DoDot:2
IF 'I
QUIT
+11 SET J=J+1
SET ;
+1 SET BGPTAX(J,0)=J_") "_BGPT
+2 SET $EXTRACT(BGPTAX(J,0),38)=$$VAL^XBDIQ1(90560.08,BGPY,.02)
+3 SET $EXTRACT(BGPTAX(J,0),55)=BGPDESC
+4 SET BGPTAX("IDX",J,J)=I_U_$SELECT(BGPTYPE'="L":"T",1:"L")_U_BGPY
+5 SET C=C+1
+6 QUIT
End DoDot:1
+7 SET (VALMCNT,BGPHIGH)=C
+8 QUIT
+9 ;
+10 ;
+11 KILL BGPTAX
SET BGPHIGH=""
SET C=0
+12 SET T=""
SET J=0
SET C=0
FOR
SET T=$ORDER(^BGPTAXR("B",T))
IF T=""
QUIT
Begin DoDot:1
+13 SET Y=0
FOR
SET Y=$ORDER(^BGPTAXR("B",T,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+14 SET N=^BGPTAXR(Y,0)
+15 ;TYPE
SET Z=$PIECE(N,U,2)
+16 IF Z="L"
SET BGPT=$ORDER(^ATXLAB("B",T,0))
+17 IF Z'="L"
SET BGPT=$ORDER(^ATXAX("B",T,0))
+18 IF Z=""
QUIT
+19 SET J=J+1
+20 SET BGPTAX(J,0)=J_") "_T
SET $EXTRACT(BGPTAX(J,0),39)=$$VAL^XBDIQ1(90560.08,Y,.02)
Begin DoDot:3
+21 SET A=""
SET B=0
FOR
SET B=$ORDER(^BGPTAXR(Y,12,B))
IF B'=+B
QUIT
SET R=$PIECE(^BGPTAXR(Y,12,B,0),U)
IF A]""
SET A=A_";"
SET A=A_$SELECT(R=1:"National GPRA",R=2:"Local CRS",R=3:"HEDIS",R=4:"ELDER",R=5:"CMS",1:"")
+22 SET $EXTRACT(BGPTAX(J,0),60)=A
End DoDot:3
+23 SET BGPTAX("IDX",J,J)=BGPT_U_Z_U_Y
+24 SET C=C+1
End DoDot:2
+25 QUIT
End DoDot:1
+26 SET (VALMCNT,BGPHIGH)=C
+27 QUIT
+28 ;
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 ;
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 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 ;D FULL^VALM1 W:$D(IOF) @IOF
+11 DO EP^BGP8XTV1(BGPTIEN,BGPTYPE,BGPFIEN)
DISPX ;
+1 DO BACK
+2 QUIT
