- BUDERP6J ;IHS/CMI/LAB - UDS REPORT T6B PROCESS;
- ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
- ;
- ;
- S(V) ;
- S BUDDECNT=BUDDECNT+1
- S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
- Q
- ;------
- CADLIST1 ;EP
- D EOJ
- S BUDCAD1L=1
- D CAD1
- G EN1^BUDERP6B
- CAD2LIST ;EP
- D EOJ
- S BUDCAD2L=1
- D CAD2
- G EN1^BUDERP6B
- PAUSE ;
- K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR
- Q
- ;
- EOJ ;
- D EN^XBVK("BUD")
- Q
- CTR(X,Y) ;EP - Center X in a field Y wide.
- Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
- ;----------
- USR() ;EP - Return name of current user from ^VA(200.
- Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
- ;----------
- LOC() ;EP - Return location name from file 4 based on DUZ(2).
- Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
- ;----------
- CAD1 ;EP
- D IN6B^BUDEDU("CAD1")
- Q
- CAD1L ;EP
- S BUDP=0,BUDQUIT=0,BUDTOT=0
- D CAD1H Q:BUDQUIT
- I '$D(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
- D CAD1L1
- I BUDROT="P",$Y>(IOSL-3) D CAD1H Q:BUDQUIT
- I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITH LIPID-LOWERING THERAPY: ",BUDTOT,!
- I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITH LIPID-LOWERING THERAPY: "_BUDTOT)
- Q
- CAD1L1 ;
- I BUDROT="P",$Y>(IOSL-7) D CAD1H Q:BUDQUIT
- S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
- .S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
- ..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
- ...S DFN=0 F S DFN=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME,BUDCCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
- ....I BUDROT="P",$Y>(IOSL-3) D CAD1H Q:BUDQUIT
- ....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(BUDCCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
- ....S BUDTOT=BUDTOT+1
- ....S BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME,BUDCCOM,DFN)
- ....I BUDROT="P" W ?5,$P(BUDALL,U,1),?30,$P(BUDALL,U,2),!?5,"LDL: ",$P(BUDALL,U,3)," ","MED: ",$P(BUDALL,U,4)
- ....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_BUDCCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD) D
- .....S X=X_U_$P(BUDALL,U,1)_U_$P(BUDALL,U,2)_U_"LDL: "_$P(BUDALL,U,3)_U_$P(BUDALL,U,4) D S(X)
- Q
- CAD1HD ;
- D S(),S(),S()
- D S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
- D S($P(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
- D S("*** RPMS Uniform Data System (UDS) ***")
- D S("Patient List for Table 6B, Section I, With Lipid Therapy")
- D S($P(^DIC(4,BUDSITE,0),U))
- S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) D S(X)
- 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:"") D S(X)
- D HT6B^BUDEDU("CAD1")
- D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Date of DX^DX or Svc CD^LDL^Medication")
- Q
- CAD1H ;
- I BUDROT="D" D CAD1HD Q
- G:'BUDGPG CAD1H1
- 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
- CAD1H1 ;
- W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
- W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
- W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
- W !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
- W !,$$CTR("Patient List for Table 6B, Section I, With Lipid Therapy ",80)
- ;W !,$$CTR("Coronary Artery Disease: Lipid Therapy",80),!
- W !,$$CTR($P(^DIC(4,BUDSITE,0),U),80),!
- S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
- 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),!
- W $TR($J("",80)," ","-")
- I BUDP=0 D
- .D HT6B^BUDEDU("CAD1")
- W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
- W !?5,"Date of DX",?16,"DX or Svc CD",?30,"Medication"
- W !,$TR($J("",80)," ","-"),!
- S BUDP=1
- Q
- ;
- ;----------
- CAD2 ;EP
- D IN6B^BUDEDU("CAD2")
- Q
- CAD2L ;EP
- S BUDP=0,BUDQUIT=0,BUDTOT=0,BUDX2ALG=0
- D CAD2H Q:BUDQUIT
- I '$D(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2")),'$D(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
- D CAD2L1
- I BUDROT="P",$Y>(IOSL-3) D CAD2H Q:BUDQUIT
- I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITHOUT LIPID-LOWERING THERAPY: ",BUDTOT,!
- I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITHOUT LIPID-LOWERING THERAPY: "_BUDTOT)
- S BUDP=0,BUDQUIT=0,BUDTOT=0,BUDX2ALG=1
- ;D CAD2H Q:BUDQUIT
- ;I '$D(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2")) D Q
- ;.I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: 0",! Q
- ;.I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: 0")
- ;D CAD2ALG
- ;I BUDROT="P",$Y>(IOSL-3) D CAD2H Q:BUDQUIT
- ;I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: ",BUDTOT,!
- ;I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: "_BUDTOT)
- Q
- CAD2ALG ;
- I BUDROT="P",$Y>(IOSL-7) D CAD2H Q:BUDQUIT
- S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
- .S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
- ..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
- ...S DFN=0 F S DFN=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME,BUDCCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
- ....I BUDROT="P",$Y>(IOSL-3) D CAD2H Q:BUDQUIT
- ....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(BUDCCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
- ....S BUDTOT=BUDTOT+1
- ....S BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME,BUDCCOM,DFN)
- ....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))
- ....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_BUDCCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)_U_X D
- .....S X=X_U_$P(BUDALL,U,1)_U_$P(BUDALL,U,2)_U_"LDL: "_$P(BUDALL,U,3)_U_$P(BUDALL,U,4) D S(X)
- Q
- CAD2L1 ;
- I BUDROT="P",$Y>(IOSL-7) D CAD2H Q:BUDQUIT
- S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
- .S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
- ..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
- ...S DFN=0 F S DFN=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME,BUDCCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
- ....I BUDROT="P",$Y>(IOSL-3) D CAD2H Q:BUDQUIT
- ....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(BUDCCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
- ....S BUDTOT=BUDTOT+1
- ....S BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME,BUDCCOM,DFN)
- ....I BUDROT="P" W ?5,$P(BUDALL,U,1),?30,$P(BUDALL,U,2),!?5,"LDL: ",$P(BUDALL,U,3)," ","MED: ",$P(BUDALL,U,4)
- ....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_BUDCCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD) D
- .....S X=X_U_$P(BUDALL,U,1)_U_$P(BUDALL,U,2)_U_"LDL: "_$P(BUDALL,U,3)_U_$P(BUDALL,U,4) D S(X)
- Q
- CAD2HD ;
- D S(),S(),S()
- D S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
- D S($P(^VA(200,DUZ,0),U,2)_" "_$$DATE^BUDEUTL1(DT))
- D S("*** RPMS Uniform Data System (UDS) ***")
- D S("Patient List for Table 6B, Section I, Without Lipid Therapy")
- ;D S("Coronary Artery Disease: Lipid Therapy")
- D S($P(^DIC(4,BUDSITE,0),U))
- S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) D S(X)
- 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:"") D S(X)
- D HT6B^BUDEDU("CAD2")
- D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Date of DX^DX or Svc CD^LDL^Medication")
- I BUDROT="P" W "CAD Patients w/o Lipid Lowering Medication",!
- ;I BUDROT="P",BUDX2ALG W "CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication"
- ;I BUDROT="D" D S("CAD Patients with w/o Lipid Lowering Medication")
- ;I BUDROT="D",BUDX2ALG D S("CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication")
- Q
- CAD2H ;
- I BUDROT="D" D CAD2HD Q
- G:'BUDGPG CAD2H1
- 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
- CAD2H1 ;
- W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
- W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
- W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
- W !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
- W !,$$CTR("Patient List for Table 6B, Section I, Without Lipid Therapy",80)
- ;W !,$$CTR("Coronary Artery Disease: Lipid Therapy",80),!
- W !,$$CTR($P(^DIC(4,BUDSITE,0),U),80),!
- S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
- 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),!
- W $TR($J("",80)," ","-")
- I BUDP=0 D
- .D HT6B^BUDEDU("CAD2")
- W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
- W !?5,"Date of DX",?16,"DX or Svc CD",?30,"Medication"
- W !,$TR($J("",80)," ","-"),!
- ;I 'BUDX2ALG W "CAD Patients with LDL >=130 w/o Lipid Lowering Medication",!
- ;I BUDX2ALG W "CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication"
- S BUDP=1
- Q
- ;
- BUDERP6J ;IHS/CMI/LAB - UDS REPORT T6B PROCESS;
- +1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
- +2 ;
- +3 ;
- S(V) ;
- +1 SET BUDDECNT=BUDDECNT+1
- +2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
- +3 QUIT
- +4 ;------
- CADLIST1 ;EP
- +1 DO EOJ
- +2 SET BUDCAD1L=1
- +3 DO CAD1
- +4 GOTO EN1^BUDERP6B
- CAD2LIST ;EP
- +1 DO EOJ
- +2 SET BUDCAD2L=1
- +3 DO CAD2
- +4 GOTO EN1^BUDERP6B
- PAUSE ;
- +1 KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="PRESS ENTER"
- KILL DA
- DO ^DIR
- KILL DIR
- +2 QUIT
- +3 ;
- EOJ ;
- +1 DO EN^XBVK("BUD")
- +2 QUIT
- CTR(X,Y) ;EP - Center X in a field Y wide.
- +1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
- +2 ;----------
- USR() ;EP - Return name of current user from ^VA(200.
- +1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
- +2 ;----------
- LOC() ;EP - Return location name from file 4 based on DUZ(2).
- +1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
- +2 ;----------
- CAD1 ;EP
- +1 DO IN6B^BUDEDU("CAD1")
- +2 QUIT
- CAD1L ;EP
- +1 SET BUDP=0
- SET BUDQUIT=0
- SET BUDTOT=0
- +2 DO CAD1H
- IF BUDQUIT
- QUIT
- +3 IF '$DATA(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1"))
- IF BUDROT="P"
- WRITE !!,"No patients to report."
- IF BUDROT="D"
- DO S()
- IF BUDROT="D"
- DO S("No patients to report.")
- QUIT
- +4 DO CAD1L1
- +5 IF BUDROT="P"
- IF $Y>(IOSL-3)
- DO CAD1H
- IF BUDQUIT
- QUIT
- +6 IF BUDROT="P"
- WRITE !!,"TOTAL CAD PATIENTS WITH LIPID-LOWERING THERAPY: ",BUDTOT,!
- +7 IF BUDROT="D"
- DO S()
- DO S("TOTAL CAD PATIENTS WITH LIPID-LOWERING THERAPY: "_BUDTOT)
- +8 QUIT
- CAD1L1 ;
- +1 IF BUDROT="P"
- IF $Y>(IOSL-7)
- DO CAD1H
- IF BUDQUIT
- QUIT
- +2 SET BUDAGE=""
- FOR
- SET BUDAGE=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE))
- IF BUDAGE=""!(BUDQUIT)
- QUIT
- Begin DoDot:1
- +3 SET BUDNAME=""
- FOR
- SET BUDNAME=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME))
- IF BUDNAME=""!(BUDQUIT)
- QUIT
- Begin DoDot:2
- +4 SET BUDCCOM=""
- FOR
- SET BUDCCOM=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME,BUDCCOM))
- IF BUDCCOM=""!(BUDQUIT)
- QUIT
- Begin DoDot:3
- +5 SET DFN=0
- FOR
- SET DFN=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME,BUDCCOM,DFN))
- IF DFN'=+DFN!(BUDQUIT)
- QUIT
- Begin DoDot:4
- +6 IF BUDROT="P"
- IF $Y>(IOSL-3)
- DO CAD1H
- IF BUDQUIT
- QUIT
- +7 IF BUDROT="P"
- WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,25),?29,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$EXTRACT(BUDCCOM,1,25),?70,$PIECE(^DPT(DFN,0),U,2),?75,
- BUDAGE,!
- +8 SET BUDTOT=BUDTOT+1
- +9 SET BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"CAD1",BUDAGE,BUDNAME,BUDCCOM,DFN)
- +10 IF BUDROT="P"
- WRITE ?5,$PIECE(BUDALL,U,1),?30,$PIECE(BUDALL,U,2),!?5,"LDL: ",$PIECE(BUDALL,U,3)," ","MED: ",$PIECE(BUDALL,U,4)
- +11 IF BUDROT="D"
- SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCCOM_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
- Begin DoDot:5
- +12 SET X=X_U_$PIECE(BUDALL,U,1)_U_$PIECE(BUDALL,U,2)_U_"LDL: "_$PIECE(BUDALL,U,3)_U_$PIECE(BUDALL,U,4)
- DO S(X)
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 QUIT
- CAD1HD ;
- +1 DO S()
- DO S()
- DO S()
- +2 DO S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
- +3 DO S($PIECE(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
- +4 DO S("*** RPMS Uniform Data System (UDS) ***")
- +5 DO S("Patient List for Table 6B, Section I, With Lipid Therapy")
- +6 DO S($PIECE(^DIC(4,BUDSITE,0),U))
- +7 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
- DO S(X)
- +8 SET X="Population: "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
- DO S(X)
- +9 DO HT6B^BUDEDU("CAD1")
- +10 DO S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Date of DX^DX or Svc CD^LDL^Medication")
- +11 QUIT
- CAD1H ;
- +1 IF BUDROT="D"
- DO CAD1HD
- QUIT
- +2 IF 'BUDGPG
- GOTO CAD1H1
- +3 KILL DIR
- IF $EXTRACT(IOST)="C"
- IF IO=IO(0)
- IF '$DATA(ZTQUEUED)
- WRITE !
- SET DIR(0)="EO"
- DO ^DIR
- KILL DIR
- IF Y=0!(Y="^")!($DATA(DTOUT))
- SET BUDQUIT=1
- QUIT
- CAD1H1 ;
- +1 IF $DATA(IOF)
- WRITE @IOF
- SET BUDGPG=BUDGPG+1
- +2 WRITE !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
- +3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
- +4 WRITE !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
- +5 WRITE !,$$CTR("Patient List for Table 6B, Section I, With Lipid Therapy ",80)
- +6 ;W !,$$CTR("Coronary Artery Disease: Lipid Therapy",80),!
- +7 WRITE !,$$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!
- +8 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
- WRITE $$CTR(X,80),!
- +9 SET X="Population: "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
- WRITE $$CTR(X,80),!
- +10 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
- +11 IF BUDP=0
- Begin DoDot:1
- +12 DO HT6B^BUDEDU("CAD1")
- End DoDot:1
- +13 WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
- +14 WRITE !?5,"Date of DX",?16,"DX or Svc CD",?30,"Medication"
- +15 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
- +16 SET BUDP=1
- +17 QUIT
- +18 ;
- +19 ;----------
- CAD2 ;EP
- +1 DO IN6B^BUDEDU("CAD2")
- +2 QUIT
- CAD2L ;EP
- +1 SET BUDP=0
- SET BUDQUIT=0
- SET BUDTOT=0
- SET BUDX2ALG=0
- +2 DO CAD2H
- IF BUDQUIT
- QUIT
- +3 IF '$DATA(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2"))
- IF '$DATA(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2"))
- IF BUDROT="P"
- WRITE !!,"No patients to report."
- IF BUDROT="D"
- DO S()
- IF BUDROT="D"
- DO S("No patients to report.")
- QUIT
- +4 DO CAD2L1
- +5 IF BUDROT="P"
- IF $Y>(IOSL-3)
- DO CAD2H
- IF BUDQUIT
- QUIT
- +6 IF BUDROT="P"
- WRITE !!,"TOTAL CAD PATIENTS WITHOUT LIPID-LOWERING THERAPY: ",BUDTOT,!
- +7 IF BUDROT="D"
- DO S()
- DO S("TOTAL CAD PATIENTS WITHOUT LIPID-LOWERING THERAPY: "_BUDTOT)
- +8 SET BUDP=0
- SET BUDQUIT=0
- SET BUDTOT=0
- SET BUDX2ALG=1
- +9 ;D CAD2H Q:BUDQUIT
- +10 ;I '$D(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2")) D Q
- +11 ;.I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: 0",! Q
- +12 ;.I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: 0")
- +13 ;D CAD2ALG
- +14 ;I BUDROT="P",$Y>(IOSL-3) D CAD2H Q:BUDQUIT
- +15 ;I BUDROT="P" W !!,"TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: ",BUDTOT,!
- +16 ;I BUDROT="D" D S(),S("TOTAL CAD PATIENTS WITH ALG OR ADV REACTION TO LIPID-LOWERING THERAPY: "_BUDTOT)
- +17 QUIT
- CAD2ALG ;
- +1 IF BUDROT="P"
- IF $Y>(IOSL-7)
- DO CAD2H
- IF BUDQUIT
- QUIT
- +2 SET BUDAGE=""
- FOR
- SET BUDAGE=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE))
- IF BUDAGE=""!(BUDQUIT)
- QUIT
- Begin DoDot:1
- +3 SET BUDNAME=""
- FOR
- SET BUDNAME=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME))
- IF BUDNAME=""!(BUDQUIT)
- QUIT
- Begin DoDot:2
- +4 SET BUDCCOM=""
- FOR
- SET BUDCCOM=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME,BUDCCOM))
- IF BUDCCOM=""!(BUDQUIT)
- QUIT
- Begin DoDot:3
- +5 SET DFN=0
- FOR
- SET DFN=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME,BUDCCOM,DFN))
- IF DFN'=+DFN!(BUDQUIT)
- QUIT
- Begin DoDot:4
- +6 IF BUDROT="P"
- IF $Y>(IOSL-3)
- DO CAD2H
- IF BUDQUIT
- QUIT
- +7 IF BUDROT="P"
- WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,25),?29,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$EXTRACT(BUDCCOM,1,25),?70,$PIECE(^DPT(DFN,0),U,2),?75,
- BUDAGE,!
- +8 SET BUDTOT=BUDTOT+1
- +9 SET BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,BUDNAME,BUDCCOM,DFN)
- +10 IF BUDROT="P"
- WRITE ?5,$PIECE(BUDALL,U,1),?30,$PIECE(BUDALL,U,2),!?5,"LDL: ",$PIECE(BUDALL,U,3)," ",$$FMTE^XLFDT($PIECE(BUDALL,U,4))
- +11 IF BUDROT="D"
- SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCCOM_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)_U_X
- Begin DoDot:5
- +12 SET X=X_U_$PIECE(BUDALL,U,1)_U_$PIECE(BUDALL,U,2)_U_"LDL: "_$PIECE(BUDALL,U,3)_U_$PIECE(BUDALL,U,4)
- DO S(X)
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 QUIT
- CAD2L1 ;
- +1 IF BUDROT="P"
- IF $Y>(IOSL-7)
- DO CAD2H
- IF BUDQUIT
- QUIT
- +2 SET BUDAGE=""
- FOR
- SET BUDAGE=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE))
- IF BUDAGE=""!(BUDQUIT)
- QUIT
- Begin DoDot:1
- +3 SET BUDNAME=""
- FOR
- SET BUDNAME=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME))
- IF BUDNAME=""!(BUDQUIT)
- QUIT
- Begin DoDot:2
- +4 SET BUDCCOM=""
- FOR
- SET BUDCCOM=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME,BUDCCOM))
- IF BUDCCOM=""!(BUDQUIT)
- QUIT
- Begin DoDot:3
- +5 SET DFN=0
- FOR
- SET DFN=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME,BUDCCOM,DFN))
- IF DFN'=+DFN!(BUDQUIT)
- QUIT
- Begin DoDot:4
- +6 IF BUDROT="P"
- IF $Y>(IOSL-3)
- DO CAD2H
- IF BUDQUIT
- QUIT
- +7 IF BUDROT="P"
- WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,25),?29,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$EXTRACT(BUDCCOM,1,25),?70,$PIECE(^DPT(DFN,0),U,2),?75,
- BUDAGE,!
- +8 SET BUDTOT=BUDTOT+1
- +9 SET BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"CAD2",BUDAGE,BUDNAME,BUDCCOM,DFN)
- +10 IF BUDROT="P"
- WRITE ?5,$PIECE(BUDALL,U,1),?30,$PIECE(BUDALL,U,2),!?5,"LDL: ",$PIECE(BUDALL,U,3)," ","MED: ",$PIECE(BUDALL,U,4)
- +11 IF BUDROT="D"
- IF BUDROT="D"
- SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCCOM_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
- Begin DoDot:5
- +12 SET X=X_U_$PIECE(BUDALL,U,1)_U_$PIECE(BUDALL,U,2)_U_"LDL: "_$PIECE(BUDALL,U,3)_U_$PIECE(BUDALL,U,4)
- DO S(X)
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 QUIT
- CAD2HD ;
- +1 DO S()
- DO S()
- DO S()
- +2 DO S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
- +3 DO S($PIECE(^VA(200,DUZ,0),U,2)_" "_$$DATE^BUDEUTL1(DT))
- +4 DO S("*** RPMS Uniform Data System (UDS) ***")
- +5 DO S("Patient List for Table 6B, Section I, Without Lipid Therapy")
- +6 ;D S("Coronary Artery Disease: Lipid Therapy")
- +7 DO S($PIECE(^DIC(4,BUDSITE,0),U))
- +8 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
- DO S(X)
- +9 SET X="Population: "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
- DO S(X)
- +10 DO HT6B^BUDEDU("CAD2")
- +11 DO S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Date of DX^DX or Svc CD^LDL^Medication")
- +12 IF BUDROT="P"
- WRITE "CAD Patients w/o Lipid Lowering Medication",!
- +13 ;I BUDROT="P",BUDX2ALG W "CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication"
- +14 ;I BUDROT="D" D S("CAD Patients with w/o Lipid Lowering Medication")
- +15 ;I BUDROT="D",BUDX2ALG D S("CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication")
- +16 QUIT
- CAD2H ;
- +1 IF BUDROT="D"
- DO CAD2HD
- QUIT
- +2 IF 'BUDGPG
- GOTO CAD2H1
- +3 KILL DIR
- IF $EXTRACT(IOST)="C"
- IF IO=IO(0)
- IF '$DATA(ZTQUEUED)
- WRITE !
- SET DIR(0)="EO"
- DO ^DIR
- KILL DIR
- IF Y=0!(Y="^")!($DATA(DTOUT))
- SET BUDQUIT=1
- QUIT
- CAD2H1 ;
- +1 IF $DATA(IOF)
- WRITE @IOF
- SET BUDGPG=BUDGPG+1
- +2 WRITE !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
- +3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
- +4 WRITE !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
- +5 WRITE !,$$CTR("Patient List for Table 6B, Section I, Without Lipid Therapy",80)
- +6 ;W !,$$CTR("Coronary Artery Disease: Lipid Therapy",80),!
- +7 WRITE !,$$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!
- +8 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
- WRITE $$CTR(X,80),!
- +9 SET X="Population: "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
- WRITE $$CTR(X,80),!
- +10 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
- +11 IF BUDP=0
- Begin DoDot:1
- +12 DO HT6B^BUDEDU("CAD2")
- End DoDot:1
- +13 WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
- +14 WRITE !?5,"Date of DX",?16,"DX or Svc CD",?30,"Medication"
- +15 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
- +16 ;I 'BUDX2ALG W "CAD Patients with LDL >=130 w/o Lipid Lowering Medication",!
- +17 ;I BUDX2ALG W "CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication"
- +18 SET BUDP=1
- +19 QUIT
- +20 ;