Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP4CTS

BGP4CTS.m

Go to the documentation of this file. 
  1. BGP4CTS ; IHS/CMI/LAB - DISPLAY IND LISTS 15 Dec 2010 9:42 AM ;
  1.  ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
  1.  ;; ;
  1. EP ;EP - CALLED FROM OPTION
  1.  I BGPRPTTT="C" S BGPRPTT2="CMS",BGPRPTT1=5
  1.  I BGPRPTTT="E" S BGPRPTT2="ELDER REPORT",BGPRPTT1=4
  1.  I BGPRPTTT="N" S BGPRPTT2="NATIONAL GPRA REPORT",BGPRPTT1=1
  1.  I BGPRPTTT="A" S BGPRPTT2="ALL CRS REPORTS",BGPRPTT1=9
  1.  I BGPRPTTT="H" S BGPRPTT2="HEDIS",BGPRPTT1=3
  1.  I BGPRPTTT="O" S BGPRPTT2="OTHER NATIONAL MEASURES",BGPRPTT1=7
  1.  I BGPRPTTT="X" S BGPRPTT2="EXECUTIVE ORDER TRANSPARENCY QUALITY MEASURES",BGPRPTT1=8
  1.  D EN
  1.  Q
  1. EOJ ;EP
  1.  D EN^XBVK("BGP")
  1.  Q
  1.  ;; ;
  1. EN ;EP -- main entry point for 
  1.  D EN^VALM("BGP 14 CRS TAXONOMY UPDATE")
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  D EOJ
  1.  Q
  1.  ;
  1. PAUSE ;EP
  1.  Q:$E(IOST)'="C"!(IO'=IO(0))
  1.  W ! S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q
  1. HDR ; -- header code
  1.  S VALMHDR(1)="TAXONOMIES TO SUPPORT 2014 "_BGPRPTT2_" REPORTING"
  1.  Q
  1.  ;
  1. INIT ;EP -- init variables and list array
  1.  I '$G(BGPRPTT1) S BGPRPTT1=9
  1.  K BGPTAX S BGPHIGH="",C=0,J=0
  1.  S BGPT="" F  S BGPT=$O(^BGPTAXJ("B",BGPT)) Q:BGPT=""  D
  1.  .S BGPY=$O(^BGPTAXJ("B",BGPT,0))
  1.  .Q:$P(^BGPTAXJ(BGPY,0),U,4)'=1
  1.  .I BGPRPTT1=9 Q:'$O(^BGPTAXJ(BGPY,12,0))
  1.  .I BGPRPTT1'=9,'$D(^BGPTAXJ(BGPY,12,"B",BGPRPTT1)) Q
  1.  .S BGPTYPE=$P(^BGPTAXJ(BGPY,0),U,2),BGPDESC=$G(^BGPTAXJ(BGPY,11,1,0)),BGPEDIT=$P(^BGPTAXJ(BGPY,0),U,4),J=J+1
  1.  .I BGPTYPE'="L" D  Q:'I
  1.  ..S I=$O(^ATXAX("B",BGPT,0))
  1.  .I BGPTYPE="L" D  Q:'I
  1.  ..S I=$O(^ATXLAB("B",BGPT,0))
  1.  .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:"")
  1.  .S $E(BGPTAX(J,0),38)=$$VAL^XBDIQ1(90552.08,BGPY,.02)
  1.  .S $E(BGPTAX(J,0),50)=BGPDESC
  1.  .S BGPTAX("IDX",J,J)=I_U_$S(BGPTYPE'="L":"T",1:"L")_U_BGPY
  1.  .S C=C+1
  1.  .Q
  1.  S (VALMCNT,BGPHIGH)=C
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. BACK ;go back to listman
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D INIT
  1.  D HDR
  1.  K DIR
  1.  K X,Y,Z,I
  1.  Q
  1.  ;
  1. ADD ;EP - add an item to the selected list - called from a protocol
  1.  D FULL^VALM1
  1.  W !
  1.  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
  1.  S DIR(0)="NO^1:"_BGPHIGH,DIR("A")="Which Taxonomy"
  1.  D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !,"No taxonomy selected." G ADDX
  1.  I $D(DIRUT) W !,"No taxonomy selected." G ADDX
  1.  S BGPTAXI=$P(BGPTAX("IDX",Y,Y),U,1),BGPTAXJ=$P(BGPTAX("IDX",Y,Y),U,2),BGPTAXN=$P(BGPTAX("IDX",Y,Y),U,3),BGPEDIT=$P(^BGPTAXJ(BGPTAXN,0),U,4)
  1.  I BGPTAXJ="L" S BGPTAXN=$P(^ATXLAB(BGPTAXI,0),U)
  1.  I BGPTAXJ="T" S BGPTAXN=$P(^ATXAX(BGPTAXI,0),U)
  1.  I BGPTAXJ="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
  1.  I BGPTAXJ="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
  1.  D FULL^VALM1 W:$D(IOF) @IOF
  1.  D EP^BGP4CTL(BGPTAXI)
  1. ADDX ;
  1.  D BACK
  1.  Q
  1. DISP ;EP
  1.  W !
  1.  S DIR(0)="NO^1:"_BGPHIGH,DIR("A")="Which Taxonomy"
  1.  D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !,"No taxonomy selected." G DISPX
  1.  I $D(DIRUT) W !,"No taxonomy selected." G DISPX
  1.  S BGPFIEN=$P(BGPTAX("IDX",Y,Y),U,3)
  1.  S BGPSEL=Y
  1.  S BGPTIEN=$P(BGPTAX("IDX",Y,Y),U,1)
  1.  S BGPTYPE=$P(BGPTAX("IDX",Y,Y),U,2)
  1.  S BGPFIEN=$P(BGPTAX("IDX",Y,Y),U,3)
  1.  D FULL^VALM1 W:$D(IOF) @IOF
  1.  D EP^BGP4XTV1(BGPTIEN,BGPTYPE,BGPFIEN)
  1. DISPX ;
  1.  D BACK
  1.  Q
  1. DISP1 ;EP - add an item to the selected list - called from a protocol
  1.  W !
  1.  S DIR(0)="NO^1:"_BGPHIGH,DIR("A")="Which Taxonomy"
  1.  D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !,"No taxonomy selected." G DISPX
  1.  I $D(DIRUT) W !,"No taxonomy selected." G DISPX
  1.  D FULL^VALM1 W:$D(IOF) @IOF
  1.  S BGPTAXI=$P(BGPTAX("IDX",Y,Y),U,1),BGPTAXJ=$P(BGPTAX("IDX",Y,Y),U,2)
  1.  W !!!,$S(BGPTAXJ="L":$P(^ATXLAB(BGPTAXI,0),U),1:$P(^ATXAX(BGPTAXI,0),U))
  1.  W !!,"Items currently defined to this taxonomy:"
  1.  I BGPTAXJ="L" S X=0 F  S X=$O(^ATXLAB(BGPTAXI,21,"B",X)) Q:X=""  D
  1.  .S Y=$P($G(^LAB(60,X,0)),U) W !?5,Y
  1.  I BGPTAXJ="T",'$P(^ATXAX(BGPTAXI,0),U,13) S X=0 F  S X=$O(^ATXAX(BGPTAXI,21,"B",X)) Q:X=""  D
  1.  .W !?5,$$VAL^XBDIQ1($P(^ATXAX(BGPTAXI,0),U,15),X,.01)
  1.  I BGPTAXJ="T",$P(^ATXAX(BGPTAXI,0),U,13) S X=0 F  S X=$O(^ATXAX(BGPTAXI,21,"B",X)) Q:X=""  D
  1.  .S H=0 F  S H=$O(^ATXAX(BGPTAXI,21,"B",X,H)) Q:H=""  D
  1.  ..W !?5,$P(^ATXAX(BGPTAXI,21,H,0),U)_"-"_$P(^ATXAX(BGPTAXI,21,H,0),U,2)
  1.  W !!
  1.  K DIR S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR
  1. DISP1X ;
  1.  D BACK
  1.  Q