- BGP1XTV ; IHS/CMI/LAB - DISPLAY IND LISTS 15 Dec 2010 9:42 AM ;
- ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
- ;; ;
- 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 11 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(^BGPTAXB("B",BGPT)) Q:BGPT="" D
- .S BGPY=$O(^BGPTAXB("B",BGPT,0))
- .Q:'$O(^BGPTAXB(BGPY,12,0))
- .S BGPTYPE=$P(^BGPTAXB(BGPY,0),U,2),BGPDESC=$G(^BGPTAXB(BGPY,11,1,0)),BGPEDIT=$P(^BGPTAXB(BGPY,0),U,4),J=J+1
- .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 BGPTAX(J,0)=J_") "_BGPT
- .S $E(BGPTAX(J,0),38)=$$VAL^XBDIQ1(90377.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(^BGPTAXB("B",T)) Q:T="" D
- .S Y=0 F S Y=$O(^BGPTAXB("B",T,Y)) Q:Y'=+Y D
- ..S N=^BGPTAXB(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(90377.08,Y,.02) D
- ...S A="",B=0 F S B=$O(^BGPTAXB(Y,12,B)) Q:B'=+B S R=$P(^BGPTAXB(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^BGP1XTV1(BGPTIEN,BGPTYPE,BGPFIEN)
- DISPX ;
- D BACK
- Q
- BGP1XTV ; IHS/CMI/LAB - DISPLAY IND LISTS 15 Dec 2010 9:42 AM ;
- +1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
- +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 11 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(^BGPTAXB("B",BGPT))
- IF BGPT=""
- QUIT
- Begin DoDot:1
- +4 SET BGPY=$ORDER(^BGPTAXB("B",BGPT,0))
- +5 IF '$ORDER(^BGPTAXB(BGPY,12,0))
- QUIT
- +6 SET BGPTYPE=$PIECE(^BGPTAXB(BGPY,0),U,2)
- SET BGPDESC=$GET(^BGPTAXB(BGPY,11,1,0))
- SET BGPEDIT=$PIECE(^BGPTAXB(BGPY,0),U,4)
- SET J=J+1
- +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 BGPTAX(J,0)=J_") "_BGPT
- +12 SET $EXTRACT(BGPTAX(J,0),38)=$$VAL^XBDIQ1(90377.08,BGPY,.02)
- +13 SET $EXTRACT(BGPTAX(J,0),55)=BGPDESC
- +14 SET BGPTAX("IDX",J,J)=I_U_$SELECT(BGPTYPE'="L":"T",1:"L")_U_BGPY
- +15 SET C=C+1
- +16 QUIT
- End DoDot:1
- +17 SET (VALMCNT,BGPHIGH)=C
- +18 QUIT
- +19 ;
- +20 ;
- +21 KILL BGPTAX
- SET BGPHIGH=""
- SET C=0
- +22 SET T=""
- SET J=0
- SET C=0
- FOR
- SET T=$ORDER(^BGPTAXB("B",T))
- IF T=""
- QUIT
- Begin DoDot:1
- +23 SET Y=0
- FOR
- SET Y=$ORDER(^BGPTAXB("B",T,Y))
- IF Y'=+Y
- QUIT
- Begin DoDot:2
- +24 SET N=^BGPTAXB(Y,0)
- +25 ;TYPE
- SET Z=$PIECE(N,U,2)
- +26 IF Z="L"
- SET BGPT=$ORDER(^ATXLAB("B",T,0))
- +27 IF Z'="L"
- SET BGPT=$ORDER(^ATXAX("B",T,0))
- +28 IF Z=""
- QUIT
- +29 SET J=J+1
- +30 SET BGPTAX(J,0)=J_") "_T
- SET $EXTRACT(BGPTAX(J,0),39)=$$VAL^XBDIQ1(90377.08,Y,.02)
- Begin DoDot:3
- +31 SET A=""
- SET B=0
- FOR
- SET B=$ORDER(^BGPTAXB(Y,12,B))
- IF B'=+B
- QUIT
- SET R=$PIECE(^BGPTAXB(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:"")
- +32 SET $EXTRACT(BGPTAX(J,0),60)=A
- End DoDot:3
- +33 SET BGPTAX("IDX",J,J)=BGPT_U_Z_U_Y
- +34 SET C=C+1
- End DoDot:2
- +35 QUIT
- End DoDot:1
- +36 SET (VALMCNT,BGPHIGH)=C
- +37 QUIT
- +38 ;
- 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^BGP1XTV1(BGPTIEN,BGPTYPE,BGPFIEN)
- DISPX ;
- +1 DO BACK
- +2 QUIT
