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

BUDCRP6J.m

Go to the documentation of this file. 
  1. BUDCRP6J ; IHS/CMI/LAB - UDS REPORT DRIVER TABLE 6B ; 
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1.  ;
  1. S(V) ;
  1.  S BUDDECNT=BUDDECNT+1
  1.  S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
  1.  Q
  1.  ;------
  1. CADLIST1 ;EP
  1.  D EOJ
  1.  S BUDCAD1L=1
  1.  D CAD1
  1.  G EN1^BUDCRP6B
  1. CAD2LIST ;EP
  1.  D EOJ
  1.  S BUDCAD2L=1
  1.  D CAD2
  1.  G EN1^BUDCRP6B
  1. PAUSE ;
  1.  K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR
  1.  Q
  1.  ;
  1. EOJ ;
  1.  D EN^XBVK("BUD")
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1. CAD1 ;EP
  1.  W:$D(IOF) @IOF
  1.  W !,$$CTR($$LOC,80)
  1.  W !,$$CTR("UDS 2015",80)
  1.  W !!,"All CAD patients 18+ w/Lipid Therapy (Table 6B)",!
  1.  D GENI^BUDCRP6P
  1.  D PAUSE
  1.  W !!,"This report provides a list of all patients 18 years of age and older"
  1.  W !,"with an active diagnosis of Coronary Artery Disease (CAD) including "
  1.  W !,"myocardial infarction (MI),or have had cardiac surgery, and whose last LDL"
  1.  W !,"was greater than or equal to 130 who were prescribed a lipid-lowering "
  1.  W !,"therapy medication or have documented evidence of use by patient of lipid"
  1.  W !,"lowering medication during the report period, does not have an allergy or"
  1.  W !,"adverse reaction to lipid-lowering therapy medications, had at least two"
  1.  W !,"medical visits ever, and had a medical visit during the report period. "
  1.  W !,"Age is calculated as of December 31."
  1.  W !
  1.  Q
  1. CAD1L ;EP
  1.  S BUDP=0,BUDQUIT=0,BUDTOT=0
  1.  D CAD1H Q:BUDQUIT
  1.  I '$D(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD1")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
  1.  D CAD1L1
  1.  I BUDROT="P",$Y>(IOSL-3) D CAD1H Q:BUDQUIT
  1.  I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITH LIPID-LOWERING THERAPY:  ",BUDTOT,!
  1.  I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITH LIPID-LOWERING THERAPY:  "_BUDTOT)
  1.  Q
  1. CAD1L1 ;
  1.  I BUDROT="P",$Y>(IOSL-7) D CAD1H Q:BUDQUIT
  1.  S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD1",BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D
  1.  .S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D
  1.  ..S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D
  1.  ....I BUDROT="P",$Y>(IOSL-3) D CAD1H Q:BUDQUIT
  1.  ....I BUDROT="P" W !,$E($P(^DPT(DFN,0),U,1),1,25),?29,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
  1.  ....S BUDTOT=BUDTOT+1
  1.  ....S BUDALL=^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME,BUDCOM,DFN)
  1.  ....I BUDROT="P" W ?5,$P(BUDALL,U,1),?30,$P(BUDALL,U,2),!?5,"LDL: ",$P(BUDALL,U,3)," ",$$FMTE^XLFDT($P(BUDALL,U,4))
  1.  ....I BUDROT="D" S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCAD) D
  1.  .....S X=X_U_$P(BUDALL,U,1)_U_$P(BUDALL,U,2)_U_"LDL: "_$P(BUDALL,U,3)_" "_$$FMTE^XLFDT($P(BUDALL,U,4)) D S(X)
  1.  Q
  1. CAD1HD ;
  1.  D S(),S(),S()
  1.  D S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
  1.  D S($P(^VA(200,DUZ,0),U,2)_"    "_$$FMTE^XLFDT(DT))
  1.  D S("***  RPMS Uniform Data System (UDS)  ***")
  1.  D S("Patient List for Table 6B, Section I")
  1.  D S("Coronary Artery Disease: Lipid Therapy")
  1.  D S($P(^DIC(4,BUDSITE,0),U))
  1.  S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) D S(X)
  1.  S X="Population:  "_$S($G(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") D S(X)
  1.  D S()
  1.  D S("This report provides a list of all patients 18 years of age and older")
  1.  D S("with an active diagnosis of Coronary Artery Disease (CAD) including ")
  1.  D S("myocardial infarction (MI),or have had cardiac surgery, and whose last LDL")
  1.  D S("was greater than or equal to 130 who were prescribed a lipid-lowering ")
  1.  D S("therapy medication or have documented evidence of use by patient of lipid")
  1.  D S("lowering medication during the report period, does not have an allergy or")
  1.  D S("adverse reaction to lipid-lowering therapy medications, had at least two")
  1.  D S("medical visits ever, and had a medical visit during the report period. ")
  1.  D S("Age is calulated as of December 31.")
  1.  D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Date of DX^DX or Svc CD^Medication^LDL")
  1.  Q
  1. CAD1H ;
  1.  I BUDROT="D" D CAD1HD Q
  1.  G:'BUDGPG CAD1H1
  1.  K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
  1. CAD1H1 ;
  1.  W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
  1.  W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
  1.  W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
  1.  W !,$$CTR("***  RPMS Uniform Data System (UDS)  ***",80)
  1.  W !,$$CTR("Patient List for Table 6B, Section I, ",80)
  1.  W !,$$CTR("Coronary Artery Disease: Lipid Therapy",80),!
  1.  W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
  1.  S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
  1.  S X="Population:  "_$S($G(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!
  1.  W $TR($J("",80)," ","-")
  1.  I BUDP=0 D
  1.  .W !,"This report provides a list of all patients 18 years of age and older"
  1.  .W !,"with an active diagnosis of Coronary Artery Disease (CAD) including "
  1.  .W !,"myocardial infarction (MI),or have had cardiac surgery, and whose last LDL"
  1.  .W !,"was greater than or equal to 130 who were prescribed a lipid-lowering "
  1.  .W !,"therapy medication or have documented evidence of use by patient of lipid"
  1.  .W !,"lowering medication during the report period, does not have an allergy or"
  1.  .W !,"adverse reaction to lipid-lowering therapy medications, had at least two"
  1.  .W !,"medical visits ever, and had a medical visit during the report period. "
  1.  .W !,"Age is calculated as of December 31."
  1.  .W !
  1.  W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
  1.  W !?5,"Date of DX",?16,"DX or Svc CD",?30,"Medication"
  1.  W !,$TR($J("",80)," ","-"),!
  1.  S BUDP=1
  1.  Q
  1.  ;
  1.  ;----------
  1. CAD2 ;EP
  1.  W:$D(IOF) @IOF
  1.  W !,$$CTR($$LOC,80)
  1.  W !,$$CTR("UDS 2015",80)
  1.  W !!,"All CAD patients 18+ w/o Lipid Therapy (Table 6B)",!
  1.  D GENI^BUDCRP6P
  1.  D PAUSE
  1.  W !!,"This report provides a list of all patients 18 years of age and older"
  1.  W !,"with an active diagnosis of Coronary Artery Disease (CAD) including "
  1.  W !,"myocardial infarction (MI) or have had cardiac surgery and whose last "
  1.  W !,"LDL was greater than or equal to 130 or last recorded LDL is greater than"
  1.  W !,"1yr from last visit in the report year who were not prescribed a "
  1.  W !,"lipid-lowering therapy medication or has no documented evidence of use by"
  1.  W !,"patient of lipid lowering medication during the report period or has an "
  1.  W !,"allergy or adverse reaction to lipid-lowering therapy medications, had at"
  1.  W !,"least two medical visits ever, and had a medical visit during the report"
  1.  W !,"period."
  1.  W !,"Age is calculated as of December 31."
  1.  W !
  1.  Q
  1. CAD2L ;EP
  1.  S BUDP=0,BUDQUIT=0,BUDTOT=0,BUDX2ALG=0
  1.  D CAD2H Q:BUDQUIT
  1.  I '$D(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD2")),'$D(^XTMP("BUDCRP6B",BUDJ,BUDH,"ALG","CAD2")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
  1.  D CAD2L1
  1.  I BUDROT="P",$Y>(IOSL-3) D CAD2H Q:BUDQUIT
  1.  I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITHOUT LIPID-LOWERING THERAPY:  ",BUDTOT,!
  1.  I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITHOUT LIPID-LOWERING THERAPY: "_BUDTOT)
  1.  S BUDP=0,BUDQUIT=0,BUDTOT=0,BUDX2ALG=1
  1.  ;D CAD2H Q:BUDQUIT
  1.  I '$D(^XTMP("BUDCRP6B",BUDJ,BUDH,"ALG","CAD2")) D  Q
  1.  .I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: 0",! Q
  1.  .I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: 0")
  1.  D CAD2ALG
  1.  I BUDROT="P",$Y>(IOSL-3) D CAD2H Q:BUDQUIT
  1.  I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY:  ",BUDTOT,!
  1.  I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY:  "_BUDTOT)
  1.  Q
  1. CAD2ALG ;
  1.  I BUDROT="P",$Y>(IOSL-7) D CAD2H Q:BUDQUIT
  1.  S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D
  1.  .S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D
  1.  ..S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D
  1.  ....I BUDROT="P",$Y>(IOSL-3) D CAD2H Q:BUDQUIT
  1.  ....I BUDROT="P" W !,$E($P(^DPT(DFN,0),U,1),1,25),?29,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
  1.  ....S BUDTOT=BUDTOT+1
  1.  ....S BUDALL=^XTMP("BUDCRP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME,BUDCOM,DFN)
  1.  ....I BUDROT="P" W ?5,$P(BUDALL,U,1),?30,$P(BUDALL,U,2),!?5,"LDL: ",$P(BUDALL,U,3)," ",$$FMTE^XLFDT($P(BUDALL,U,4))
  1.  ....I BUDROT="D" S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCAD)_U_X D
  1.  .....S X=X_U_$P(BUDALL,U,1)_U_$P(BUDALL,U,2)_U_"LDL: "_$P(BUDALL,U,3)_" "_$$FMTE^XLFDT($P(BUDALL,U,4)) D S(X)
  1.  Q
  1. CAD2L1 ;
  1.  I BUDROT="P",$Y>(IOSL-7) D CAD2H Q:BUDQUIT
  1.  S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D
  1.  .S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D
  1.  ..S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D
  1.  ....I BUDROT="P",$Y>(IOSL-3) D CAD2H Q:BUDQUIT
  1.  ....I BUDROT="P" W !,$E($P(^DPT(DFN,0),U,1),1,25),?29,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
  1.  ....S BUDTOT=BUDTOT+1
  1.  ....S BUDALL=^XTMP("BUDCRP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME,BUDCOM,DFN)
  1.  ....I BUDROT="P" W ?5,$P(BUDALL,U,1),?30,$P(BUDALL,U,2),!?5,"LDL: ",$P(BUDALL,U,3)," ",$$FMTE^XLFDT($P(BUDALL,U,4))
  1.  ....I BUDROT="D" I BUDROT="D" S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCAD) D
  1.  .....S X=X_U_$P(BUDALL,U,1)_U_$P(BUDALL,U,2)_U_"LDL: "_$P(BUDALL,U,3)_" "_$$FMTE^XLFDT($P(BUDALL,U,4)) D S(X)
  1.  Q
  1. CAD2HD ;
  1.  D CAD2HD^BUDCRP6R Q
  1. CAD2H ;
  1.  I BUDROT="D" D CAD2HD Q
  1.  G:'BUDGPG CAD2H1
  1.  K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
  1. CAD2H1 ;
  1.  W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
  1.  W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
  1.  W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
  1.  W !,$$CTR("***  RPMS Uniform Data System (UDS)  ***",80)
  1.  W !,$$CTR("Patient List for Table 6B, Section I, ",80)
  1.  W !,$$CTR("Coronary Artery Disease: Lipid Therapy",80),!
  1.  W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
  1.  S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
  1.  S X="Population:  "_$S($G(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!
  1.  W $TR($J("",80)," ","-")
  1.  I BUDP=0 D
  1.  .W !!,"This report provides a list of all patients 18 years of age and older"
  1.  .W !,"with an active diagnosis of Coronary Artery Disease (CAD) including "
  1.  .W !,"myocardial infarction (MI) or have had cardiac surgery and whose last "
  1.  .W !,"LDL was greater than or equal to 130 or last recorded LDL is greater than"
  1.  .W !,"1yr from last visit in the report year who were not prescribed a "
  1.  .W !,"lipid-lowering therapy medication or has no documented evidence of use by"
  1.  .W !,"patient of lipid lowering medication during the report period or has an "
  1.  .W !,"allergy or adverse reaction to lipid-lowering therapy medications, had at"
  1.  .W !,"least two medical visits ever, and had a medical visit during the report"
  1.  .W !,"period."
  1.  .W !,"Age is calculated as of December 31."
  1.  W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
  1.  W !?5,"Date of DX",?16,"DX or Svc CD",?30,"Medication",?72,"LDL"
  1.  W !,$TR($J("",80)," ","-"),!
  1.  I 'BUDX2ALG W "CAD Patients with LDL >=130 w/o Lipid Lowering Medication",!
  1.  I BUDX2ALG W "CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication"
  1.  S BUDP=1
  1.  Q
  1.  ;