BGP5TXV ; 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 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 ; -- init variables and list array
K BGPTAX S BGPHIGH="",C=0,J=0
S BGPT="" F S BGPT=$O(^BGPTAXV("B",BGPT)) Q:BGPT="" D
.S BGPY=$O(^BGPTAXV("B",BGPT,0))
.Q:'$O(^BGPTAXV(BGPY,12,0))
.S BGPTYPE=$P(^BGPTAXV(BGPY,0),U,2),BGPDESC=$G(^BGPTAXV(BGPY,11,1,0)),BGPEDIT=$P(^BGPTAXV(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
.S $E(BGPTAX(J,0),38)=$$VAL^XBDIQ1(90371.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(^BGPTAXV("B",T)) Q:T="" D
.S Y=0 F S Y=$O(^BGPTAXV("B",T,Y)) Q:Y'=+Y D
..S N=^BGPTAXV(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(90371.08,Y,.02) D
...S A="",B=0 F S B=$O(^BGPTAXV(Y,12,B)) Q:B'=+B S R=$P(^BGPTAXV(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^BGP5TXV1(BGPTIEN,BGPTYPE,BGPFIEN)
DISPX ;
D BACK
Q
BGP5TXV ; 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 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 ; -- init variables and list array
+1 KILL BGPTAX
SET BGPHIGH=""
SET C=0
SET J=0
+2 SET BGPT=""
FOR
SET BGPT=$ORDER(^BGPTAXV("B",BGPT))
IF BGPT=""
QUIT
Begin DoDot:1
+3 SET BGPY=$ORDER(^BGPTAXV("B",BGPT,0))
+4 IF '$ORDER(^BGPTAXV(BGPY,12,0))
QUIT
+5 SET BGPTYPE=$PIECE(^BGPTAXV(BGPY,0),U,2)
SET BGPDESC=$GET(^BGPTAXV(BGPY,11,1,0))
SET BGPEDIT=$PIECE(^BGPTAXV(BGPY,0),U,4)
SET J=J+1
+6 IF BGPTYPE'="L"
Begin DoDot:2
+7 SET I=$ORDER(^ATXAX("B",BGPT,0))
End DoDot:2
+8 IF BGPTYPE="L"
Begin DoDot:2
+9 SET I=$ORDER(^ATXLAB("B",BGPT,0))
End DoDot:2
+10 SET BGPTAX(J,0)=J_") "_BGPT
+11 SET $EXTRACT(BGPTAX(J,0),38)=$$VAL^XBDIQ1(90371.08,BGPY,.02)
+12 SET $EXTRACT(BGPTAX(J,0),55)=BGPDESC
+13 SET BGPTAX("IDX",J,J)=I_U_$SELECT(BGPTYPE'="L":"T",1:"L")_U_BGPY
+14 SET C=C+1
+15 QUIT
End DoDot:1
+16 SET (VALMCNT,BGPHIGH)=C
+17 QUIT
+18 ;
+19 ;
+20 KILL BGPTAX
SET BGPHIGH=""
SET C=0
+21 SET T=""
SET J=0
SET C=0
FOR
SET T=$ORDER(^BGPTAXV("B",T))
IF T=""
QUIT
Begin DoDot:1
+22 SET Y=0
FOR
SET Y=$ORDER(^BGPTAXV("B",T,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+23 SET N=^BGPTAXV(Y,0)
+24 ;TYPE
SET Z=$PIECE(N,U,2)
+25 IF Z="L"
SET BGPT=$ORDER(^ATXLAB("B",T,0))
+26 IF Z'="L"
SET BGPT=$ORDER(^ATXAX("B",T,0))
+27 IF Z=""
QUIT
+28 SET J=J+1
+29 SET BGPTAX(J,0)=J_") "_T
SET $EXTRACT(BGPTAX(J,0),39)=$$VAL^XBDIQ1(90371.08,Y,.02)
Begin DoDot:3
+30 SET A=""
SET B=0
FOR
SET B=$ORDER(^BGPTAXV(Y,12,B))
IF B'=+B
QUIT
SET R=$PIECE(^BGPTAXV(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:"")
+31 SET $EXTRACT(BGPTAX(J,0),60)=A
End DoDot:3
+32 SET BGPTAX("IDX",J,J)=BGPT_U_Z_U_Y
+33 SET C=C+1
End DoDot:2
+34 QUIT
End DoDot:1
+35 SET (VALMCNT,BGPHIGH)=C
+36 QUIT
+37 ;
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 DO FULL^VALM1
IF $DATA(IOF)
WRITE @IOF
+11 DO EP^BGP5TXV1(BGPTIEN,BGPTYPE,BGPFIEN)
DISPX ;
+1 DO BACK
+2 QUIT
