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

BUD2RPL5.m

Go to the documentation of this file. 
  1. BUD2RPL5 ; IHS/CMI/LAB - UDS REPORT DRIVER TABLE 6B ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1.  ;
  1.  ;
  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. T4IPPL ;EP
  1.  S BUDP=0,BUDQUIT=0,BUDTOT=0
  1.  D T4IPPH Q:BUDQUIT
  1.  I '$D(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4IPPL")) W !!,"No patients to report." Q
  1.  D T4IPPL1
  1.  I $Y>(IOSL-3) D T4IPPH G:BUDQUIT T4IPPLX
  1.  W !!,"TOTAL PATIENTS: ",BUDTOT,!
  1. T4IPPLX ;
  1.  Q
  1. T4IPPL1 ;
  1.  I $Y>(IOSL-7) D T4IPPH Q:BUDQUIT
  1.  S BUDTOT=0
  1.  S BUDINCI="" F  S BUDINCI=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4IPPL",BUDINCI)) Q:BUDINCI=""!(BUDQUIT)  D
  1.  .S BUDINC="" F  S BUDINC=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4IPPL",BUDINCI,BUDINC)) Q:BUDINC=""!(BUDQUIT)  D T4IPPL2
  1.  Q
  1. T4IPPL2 ;
  1.  S BUDSTOT=0
  1.  W !,"Income as Percent of Poverty Level: ",BUDINC,!
  1.  S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4IPPL",BUDINCI,BUDINC,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  .S BUDSEX="" F  S BUDSEX=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4IPPL",BUDINCI,BUDINC,BUDCOM,BUDSEX)) Q:BUDSEX=""!(BUDQUIT)  D
  1.  ..S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4IPPL",BUDINCI,BUDINC,BUDCOM,BUDSEX,BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4IPPL",BUDINCI,BUDINC,BUDCOM,BUDSEX,BUDAGE,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D
  1.  ....I $Y>(IOSL-3) D T4IPPH Q:BUDQUIT  W !,"Income as Percent of Poverty Level: ",BUDINC,!
  1.  ....S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1
  1.  ....W !,$E($P(^DPT(DFN,0),U,1),1,22),?24,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))
  1.  ....W ?36,$E(BUDCOM,1,13),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD)
  1.  ....W !?5,BUDINC
  1.  I $Y>(IOSL-4) D T4IPPH Q:BUDQUIT
  1.  W !!,"Sub-Total Line ",BUDINCI," ",BUDINC,":  ",BUDSTOT,!
  1.  Q
  1. T4IPPH ;
  1.  G:'BUDGPG T4IPPH1
  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. T4IPPH1 ;
  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 4, Income As Percent of Poverty Level",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(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=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 with an income percent"
  1.  .W !,"of poverty level (=<100%, 101-150%, 151-200%, >200%, Unknown) during"
  1.  .W !,"the report period."
  1.  .W !,"Age is calculated as of June 30."
  1.  .W !
  1.  W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE"
  1.  W !,?5,"INCOME PERCENT OF POVERTY LEVEL"
  1.  ;W !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"
  1.  W !,$TR($J("",80)," ","-"),!
  1.  S BUDP=1
  1.  Q
  1.  ;----------
  1. T4PMIS ;EP
  1.  S BUDP=0,BUDQUIT=0,BUDTOT=0
  1.  D T4PMIH Q:BUDQUIT
  1.  I '$D(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4PMIS")) W !!,"No patients to report." Q
  1.  D T4PMIS1
  1.  I $Y>(IOSL-3) D T4PMIH G:BUDQUIT T4PMISX
  1.  W !!,"TOTAL PATIENTS: ",BUDTOT,!
  1. T4PMISX ;
  1.  Q
  1. T4PMIS1 ;
  1.  I $Y>(IOSL-7) D T4PMIH Q:BUDQUIT
  1.  S BUDTOT=0
  1.  S BUDINCI="" F  S BUDINCI=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4PMIS",BUDINCI)) Q:BUDINCI=""!(BUDQUIT)  D
  1.  .S BUDINC="" F  S BUDINC=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4PMIS",BUDINCI,BUDINC)) Q:BUDINC=""!(BUDQUIT)  D T4PMIS2
  1.  Q
  1. T4PMIS2 ;
  1.  S BUDSTOT=0
  1.  W !,"Principle Third Party Medical Insurance Source: ",BUDINC,!
  1.  S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4PMIS",BUDINCI,BUDINC,BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D
  1.  .S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4PMIS",BUDINCI,BUDINC,BUDAGE,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  ..S BUDSEX="" F  S BUDSEX=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4PMIS",BUDINCI,BUDINC,BUDAGE,BUDCOM,BUDSEX)) Q:BUDSEX=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4PMIS",BUDINCI,BUDINC,BUDAGE,BUDCOM,BUDSEX,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D
  1.  ....I $Y>(IOSL-3) D T4PMIH Q:BUDQUIT  W !,"Principle Third Party Medical Insurance Source: ",BUDINC,!
  1.  ....S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1
  1.  ....W !,$E($P(^DPT(DFN,0),U,1),1,22),?24,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))
  1.  ....W ?36,$E(BUDCOM,1,13),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD)
  1.  ....W !?5,BUDINC
  1.  I $Y>(IOSL-4) D T4PMIH Q:BUDQUIT
  1.  W !!,"Sub-Total Line ",$S(BUDINCI=8.1:"8a",BUDINCI=8.2:"8b",BUDINCI=10.1:"10a",BUDINCI=10.2:"10b",1:BUDINCI)," ",BUDINC,":  ",BUDSTOT,!
  1.  Q
  1. T4PMIH ;
  1.  G:'BUDGPG T4PMIH1
  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. T4PMIH1 ;
  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 4",80)
  1.  W !,$$CTR("Principle Third Party Medical Insurance Source",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(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=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 and the type of medical insurance"
  1.  .W !,"the patient has during the report period if any."
  1.  .W !,"Age is calculated as of June 30."
  1.  .W !
  1.  W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE"
  1.  W !,?5,"PRINCIPLE THIRD PARTY MEDICAL INSURANCE SOURCE"
  1.  ;W !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"
  1.  W !,$TR($J("",80)," ","-"),!
  1.  S BUDP=1
  1.  Q
  1.  ;----------
  1. T4CHAR ;EP
  1.  S BUDP=0,BUDQUIT=0,BUDTOT=0
  1.  D T4CHAH Q:BUDQUIT
  1.  I '$D(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4CHAR")) W !!,"No patients to report." Q
  1.  D T4CHAR1
  1.  I $Y>(IOSL-3) D T4CHAH G:BUDQUIT T4CHARX
  1.  W !!,"TOTAL PATIENTS: ",BUDTOT,!
  1. T4CHARX ;
  1.  Q
  1. T4CHAR1 ;
  1.  I $Y>(IOSL-7) D T4CHAH Q:BUDQUIT
  1.  S BUDTOT=0
  1.  S BUDINCI="" F  S BUDINCI=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4CHAR",BUDINCI)) Q:BUDINCI=""!(BUDQUIT)  D
  1.  .S BUDINC="" F  S BUDINC=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4CHAR",BUDINCI,BUDINC)) Q:BUDINC=""!(BUDQUIT)  D T4CHAR2
  1.  Q
  1. T4CHAR2 ;
  1.  S BUDSTOT=0
  1.  W !,"Special Characteristics: ",BUDINC,!
  1.  S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4CHAR",BUDINCI,BUDINC,BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D
  1.  .S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4CHAR",BUDINCI,BUDINC,BUDAGE,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  ..S BUDSEX="" F  S BUDSEX=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4CHAR",BUDINCI,BUDINC,BUDAGE,BUDCOM,BUDSEX)) Q:BUDSEX=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUD2RPT1",BUDJ,BUDH,"T4CHAR",BUDINCI,BUDINC,BUDAGE,BUDCOM,BUDSEX,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D
  1.  ....I $Y>(IOSL-3) D T4CHAH Q:BUDQUIT  W !,"Special Characteristics: ",BUDINC,!
  1.  ....S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1
  1.  ....W !,$E($P(^DPT(DFN,0),U,1),1,22),?24,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))
  1.  ....W ?36,$E(BUDCOM,1,13),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD)
  1.  ....W !?5,BUDINC
  1.  I $Y>(IOSL-4) D T4CHAH Q:BUDQUIT
  1.  W !!,"Sub-Total Line ",BUDINCI," ",BUDINC,":  ",BUDSTOT,!
  1.  Q
  1. T4CHAH ;
  1.  G:'BUDGPG T4CHAH1
  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. T4CHAH1 ;
  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 4")
  1.  W !,$$CTR("Characteristics - Special Characteristics",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(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=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 who are migrant workers,"
  1.  .W !,"seasonal workers, homeless, school based health center patients, or a"
  1.  .W !,"veteran during the report period."
  1.  .W !,"Age is calculated as of June 30."
  1.  .W !
  1.  W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE"
  1.  W !,?5,"SPECIAL CHARACTERISTIC"
  1.  ;W !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"
  1.  W !,$TR($J("",80)," ","-"),!
  1.  S BUDP=1
  1.  Q