BUDHRP6W ;IHS/CMI/LAB - UDS REPORT T6B PROCESS;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
;
;
ROTACONT(P,C,ED) ;EP - ANALPHYLAXIS/IMMUNE DEF
NEW X
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
.I $P(^BICONT(R,0),U,1)["Immune" S G=D_U_$P(^BICONT(R,0),U,1)
.I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"
Q G
;
PRGA ;EP
W:$D(IOF) @IOF
W !,$$CTR($$LOC,80)
W !,$$CTR("UDS 2018",80)
W !!,"Prenatal Patients by Age (Table 6B)",!
D GENI^BUDHRP6I
D PAUSE^BUDHRP6I
W !!,"This report provides a list of patients by age that had pregnancy-related"
W !,"visits during the past 20 months, with at least one pregnancy-related visit"
W !,"during the report period."
W !
Q
PRGAL ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D PRGAH Q:BUDQUIT
I '$D(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
S BUDAB="Less than 15 Years" D PRGAL1
I BUDQUIT G PRGALX
S BUDAB="Ages 15-19" D PRGAL1
I BUDQUIT G PRGALX
S BUDAB="Ages 20-24" D PRGAL1
I BUDQUIT G PRGALX
S BUDAB="Ages 25-44" D PRGAL1
I BUDQUIT G PRGALX
S BUDAB="Ages 45 and Over" D PRGAL1
I BUDQUIT G PRGALX
I BUDROT="P",$Y>(IOSL-3) D PRGAH G:BUDQUIT PRGALX
I BUDROT="P" W !!,"TOTAL PREGNANT PATIENTS: ",BUDTOT,!
I BUDROT="D" D S(),S("TOTAL PREGNANT PATIENTS: "_BUDTOT)
PRGALX ;
Q
PRGAL1 ;
I BUDROT="P" I $Y>(IOSL-7) D PRGAH Q:BUDQUIT
I BUDROT="P" W !,BUDAB,!
I BUDROT="D" D S(),S(BUDAB),S()
S BUDSTOT=0
S BUDA=0 F S BUDA=$O(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA)) Q:BUDA'=+BUDA!(BUDQUIT) D
.S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
....I BUDROT="P" I $Y>(IOSL-3) D PRGAH Q:BUDQUIT
....I BUDROT="P" W !?2,$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,$$AGE^AUPNPAT(DFN,BUDCCAD),!
....S BUDSTOT=BUDSTOT+1,BUDTOT=BUDTOT+1
....S BUDALL=^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCCOM,DFN)
....F BUDX=1:1 S BUDV=$P(BUDALL,U,BUDX) Q:BUDV=""!(BUDQUIT) D
.....I BUDROT="P" I $Y>(IOSL-3) D PRGAH Q:BUDQUIT
.....I $E(BUDV)="P",BUDROT="P" W ?5,BUDV,! Q ;PROB LIST
.....I $E(BUDV)="P",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_$$AGE^AUPNPAT(DFN,BUDCCAD)_U_BUDV D S(X) Q ;PROBLEM LIST
.....S V=$P(BUDV,"|"),C=$P(BUDV,"|",2) S T=$$TRIM(V)
.....I BUDROT="P" W ?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),".")),?20,C,?30,T,?41,$P(^AUPNVSIT(V,0),U,7),?49,$E($$CLINIC^APCLV(V,"E"),1,15),?65,$E($$VAL^XBDIQ1(9000010,V,.06),1,15),!
.....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_$$AGE^AUPNPAT(DFN,BUDCCAD) D
......S X=X_U_$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),"."))_U_C_U_T_U_$P(^AUPNVSIT(V,0),U,7)_U_$$CLINIC^APCLV(V,"E")_U_$$VAL^XBDIQ1(9000010,V,.06) D S(X)
I BUDROT="P" W !,"Sub-Total ",BUDAB,": ",BUDSTOT,!
I BUDROT="D" D S("Sub-Total "_BUDAB_": "_BUDSTOT),S()
Q
PRGAHD ;delimited header
D S(),S(),S()
D S("***** SENSITIVE INFORMATION *****")
D S($P(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
D S("*** RPMS Uniform Data System (UDS) "_$$VER^BUDHBAN()_" ***")
D S("Patient List for Table 6B, Sections A & B, Pregnant Patients")
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 S()
D S("List of all patients with pregnancy-related visits during the past 20")
D S("months, with at least one pregnancy-related visit during the report")
D S("period, with age and visit information. Displays community, age, and")
D S("visit data, and codes.")
D S("Age on the patient list is calculated as of June 30.")
D S()
D S("PATIENT NAME^HRN^COMMUNITY^AGE^VISIT DATE^DX/SVC CD^TRIMESTER^SVC CAT^CLINIC^LOCATION")
Q
PRGAH ;
I BUDROT="D" D PRGAHD Q
G:'BUDGPG PRGAH1
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
PRGAH1 ;
W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
W !,$$CTR("***** SENSITIVE INFORMATION *****",IOM)
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?55,"Section "_BUDSCTC_" of "_BUDTSCTC_", Page "_BUDGPG,!
W !,$$CTR("*** RPMS Uniform Data System (UDS) "_$$VER^BUDHBAN()_" ***",80)
W !,$$CTR("Patient List for Table 6B, Sections A & B, Pregnant Patients",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
.W !,"List of all patients with pregnancy-related visits during the past 20"
.W !,"months, with at least one pregnancy-related visit during the report"
.W !,"period, with age and visit information. Displays community, age, and"
.W !,"visit data, and codes."
.W !,"Age on the patient list is calculated as of June 30."
W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"AGE"
W !?5,"VISIT DATE",?20,"DX/SVC CD",?30,"TRIMESTER",?41,"SRV CAT",?49,"CLINIC",?65,"LOCATION"
W !,$TR($J("",80)," ","-"),!
S BUDP=1
Q
;
S(V) ;
S BUDDECNT=BUDDECNT+1
S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
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")
;----------
TRIM(V) ;any trimester code on this visit?
NEW X,Y,Z,T1,T2,T3
S Z=""
S T1=$O(^ATXAX("B","BGP PREGNANCY TRI 1 DXS",0))
S T2=$O(^ATXAX("B","BGP PREGNANCY TRI 2 DXS",0))
S T3=$O(^ATXAX("B","BGP PREGNANCY TRI 3 DXS",0))
S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X!(Z]"") D
.S Y=$$VALI^XBDIQ1(9000010.07,X,.01)
.I $$ICD^ATXCHK(Y,T1,9) S Z="1ST" Q
.I $$ICD^ATXCHK(Y,T2,9) S Z="2ND" Q
.I $$ICD^ATXCHK(Y,T3,9) S Z="3RD" Q
I Z]"" Q Z
Q "UNK"
PRES(P,TAX,BD,ED,NDC) ;EP
;GO THROUGH 52 FOR PATIENT
S NDC=$G(NDC)
NEW BUDD,G,Z,R,D,E,T,F,I,BUDMEDS1,Y,%,K,V,N,A,NDCT
;S BDMD=$$FMADD^XLFDT(ED,-(6*31)) ;DATE OF EXPIRATION NEEDS TO BE GREATER THAN THIS AND DAYS SUPPLY * REFILLS NEEDS TO BE GREATER THAN THIS ADDED TO ISSUE DATE
S Z=0,G="" F S Z=$O(^PS(55,P,"P",Z)) Q:Z'=+Z!(G="X") D
.S R=$P(^PS(55,P,"P",Z,0),U,1)
.Q:'$D(^PSRX(R,0)) ;bad xref
.Q:$E($P(^PSRX(R,0),U,1))'="X" ;not an E-PRES
.S D=$P(^PSRX(R,0),U,6)
.Q:'D ;no drug??
.S N=$P($G(^PSDRUG(D,2)),U,4)
.S A=0
.I $D(^ATXAX(TAX,21,"B",D)) S A=1 ;a drug we care about
.I 'A,N]"",NDC,$D(^ATXAX(NDC,21,"B",N)) S A=1
.Q:'A
.S E=$P($G(^PSRX(R,2)),U,6)
.I E,E<BD Q ;expires too soon
.S Y=$P(^PSRX(R,0),U,8) ;DAYS SUPPLY
.S F=$P(^PSRX(R,0),U,9) ;# REFILLS
.S T=Y*(F+1) ;total days supply
.S I=$P(^PSRX(R,0),U,13) ;ISSUE DATE
.Q:I>ED ;issued after report period
.Q:$$FMADD^XLFDT(I,T)<BD ;days supply doesn't get to date
.S G=$P(^PSDRUG(D,0),U,1)_U_$$DATE^BUDHUTL1(I)_U_I
I G]"" Q G
;NOW CHECK FOR E H R OUTSIDE MED IN V MED IN PAST 10 YEARS
EHROUT ;
;any EHR outside meds?
K BUDMEDS1 S K=0,R=""
S BD=$$FMADD^XLFDT(BD,-(10*365))
;S X=P_"^ALL MEDS ["_$P(^ATXAX(TAX,0),U,1)_";DURING "_$$FMADD^XLFDT(ED,-3650)_"-"_ED S E=$$START1^APCLDF(X,"BDMMEDS1(")
S NDCT=""
I NDC S NDCT=$P(^ATXAX(NDC,0),U,1)
D GETMEDS^BUDHUTL2(P,BD,ED,$P(^ATXAX(TAX,0),U),NDCT,,,.BUDMEDS1)
I '$D(BUDMEDS1) Q ""
S X=0 F S X=$O(BUDMEDS1(X)) Q:X'=+X!(R]"") S Y=+$P(BUDMEDS1(X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.Q:$P($G(^AUPNVMED(Y,11)),U,8)="" ;NOT AN EHR OUTSIDE MED
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S %=$P(^AUPNVMED(Y,0),U,8) ;discontinued date
.I %]"",%<BD Q ;if discontinued before 6M of report period
.S V=$P(^AUPNVMED(Y,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S R=$$VAL^XBDIQ1(9000010.14,Y,.01)_" (EHR OUTSIDE)"_U_$$DATE^BUDHUTL1($P($P(^AUPNVSIT(V,0),U),"."))_U_$$VD^APCLV(V)
Q R
BUDHRP6W ;IHS/CMI/LAB - UDS REPORT T6B PROCESS;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
+3 ;
+4 ;
ROTACONT(P,C,ED) ;EP - ANALPHYLAXIS/IMMUNE DEF
+1 NEW X
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Anaphylaxis"
+9 IF $PIECE(^BICONT(R,0),U,1)["Immune"
SET G=D_U_$PIECE(^BICONT(R,0),U,1)
+10 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Neomycin Allergy"
End DoDot:1
+11 QUIT G
+12 ;
PRGA ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC,80)
+3 WRITE !,$$CTR("UDS 2018",80)
+4 WRITE !!,"Prenatal Patients by Age (Table 6B)",!
+5 DO GENI^BUDHRP6I
+6 DO PAUSE^BUDHRP6I
+7 WRITE !!,"This report provides a list of patients by age that had pregnancy-related"
+8 WRITE !,"visits during the past 20 months, with at least one pregnancy-related visit"
+9 WRITE !,"during the report period."
+10 WRITE !
+11 QUIT
PRGAL ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO PRGAH
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA"))
IF BUDROT="P"
WRITE !!,"No patients to report."
IF BUDROT="D"
DO S()
IF BUDROT="D"
DO S("No patients to report.")
QUIT
+4 SET BUDAB="Less than 15 Years"
DO PRGAL1
+5 IF BUDQUIT
GOTO PRGALX
+6 SET BUDAB="Ages 15-19"
DO PRGAL1
+7 IF BUDQUIT
GOTO PRGALX
+8 SET BUDAB="Ages 20-24"
DO PRGAL1
+9 IF BUDQUIT
GOTO PRGALX
+10 SET BUDAB="Ages 25-44"
DO PRGAL1
+11 IF BUDQUIT
GOTO PRGALX
+12 SET BUDAB="Ages 45 and Over"
DO PRGAL1
+13 IF BUDQUIT
GOTO PRGALX
+14 IF BUDROT="P"
IF $Y>(IOSL-3)
DO PRGAH
IF BUDQUIT
GOTO PRGALX
+15 IF BUDROT="P"
WRITE !!,"TOTAL PREGNANT PATIENTS: ",BUDTOT,!
+16 IF BUDROT="D"
DO S()
DO S("TOTAL PREGNANT PATIENTS: "_BUDTOT)
PRGALX ;
+1 QUIT
PRGAL1 ;
+1 IF BUDROT="P"
IF $Y>(IOSL-7)
DO PRGAH
IF BUDQUIT
QUIT
+2 IF BUDROT="P"
WRITE !,BUDAB,!
+3 IF BUDROT="D"
DO S()
DO S(BUDAB)
DO S()
+4 SET BUDSTOT=0
+5 SET BUDA=0
FOR
SET BUDA=$ORDER(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA))
IF BUDA'=+BUDA!(BUDQUIT)
QUIT
Begin DoDot:1
+6 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:2
+7 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+8 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCCOM,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:4
+9 IF BUDROT="P"
IF $Y>(IOSL-3)
DO PRGAH
IF BUDQUIT
QUIT
+10 IF BUDROT="P"
WRITE !?2,$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,$$AGE^AUPNPAT(DFN,BUDCCAD)
,!
+11 SET BUDSTOT=BUDSTOT+1
SET BUDTOT=BUDTOT+1
+12 SET BUDALL=^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCCOM,DFN)
+13 FOR BUDX=1:1
SET BUDV=$PIECE(BUDALL,U,BUDX)
IF BUDV=""!(BUDQUIT)
QUIT
Begin DoDot:5
+14 IF BUDROT="P"
IF $Y>(IOSL-3)
DO PRGAH
IF BUDQUIT
QUIT
+15 ;PROB LIST
IF $EXTRACT(BUDV)="P"
IF BUDROT="P"
WRITE ?5,BUDV,!
QUIT
+16 ;PROBLEM LIST
IF $EXTRACT(BUDV)="P"
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_$$AGE^AUPNPAT(DFN,BUDCCAD)_U_BUDV
DO S(X)
QUIT
+17 SET V=$PIECE(BUDV,"|")
SET C=$PIECE(BUDV,"|",2)
SET T=$$TRIM(V)
+18 IF BUDROT="P"
WRITE ?5,$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),".")),?20,C,?30,T,?41,$PIECE(^AUPNVSIT(V,0),U,7),?49,$EXTRACT($$CLINIC^APCLV(V,"E"),1,15),?65,$EXTRACT($$VAL^XBDIQ1(9000010,V,.06),1,15),!
+19 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_$$AGE^AUPNPAT(DFN,BUDCCAD)
Begin DoDot:6
+20 SET X=X_U_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))_U_C_U_T_U_$PIECE(^AUPNVSIT(V,0),U,7)_U_$$CLINIC^APCLV(V,"E")_U_$$VAL^XBDIQ1(9000010,V,.06)
DO S(X)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF BUDROT="P"
WRITE !,"Sub-Total ",BUDAB,": ",BUDSTOT,!
+22 IF BUDROT="D"
DO S("Sub-Total "_BUDAB_": "_BUDSTOT)
DO S()
+23 QUIT
PRGAHD ;delimited header
+1 DO S()
DO S()
DO S()
+2 DO S("***** SENSITIVE INFORMATION *****")
+3 DO S($PIECE(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
+4 DO S("*** RPMS Uniform Data System (UDS) "_$$VER^BUDHBAN()_" ***")
+5 DO S("Patient List for Table 6B, Sections A & B, Pregnant Patients")
+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 S()
+10 DO S("List of all patients with pregnancy-related visits during the past 20")
+11 DO S("months, with at least one pregnancy-related visit during the report")
+12 DO S("period, with age and visit information. Displays community, age, and")
+13 DO S("visit data, and codes.")
+14 DO S("Age on the patient list is calculated as of June 30.")
+15 DO S()
+16 DO S("PATIENT NAME^HRN^COMMUNITY^AGE^VISIT DATE^DX/SVC CD^TRIMESTER^SVC CAT^CLINIC^LOCATION")
+17 QUIT
PRGAH ;
+1 IF BUDROT="D"
DO PRGAHD
QUIT
+2 IF 'BUDGPG
GOTO PRGAH1
+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
PRGAH1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET BUDGPG=BUDGPG+1
+2 WRITE !,$$CTR("***** SENSITIVE INFORMATION *****",IOM)
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?55,"Section "_BUDSCTC_" of "_BUDTSCTC_", Page "_BUDGPG,!
+4 WRITE !,$$CTR("*** RPMS Uniform Data System (UDS) "_$$VER^BUDHBAN()_" ***",80)
+5 WRITE !,$$CTR("Patient List for Table 6B, Sections A & B, Pregnant Patients",80),!
+6 WRITE $$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!
+7 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
WRITE $$CTR(X,80),!
+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:"")
WRITE $$CTR(X,80),!
+9 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+10 IF BUDP=0
Begin DoDot:1
+11 WRITE !,"List of all patients with pregnancy-related visits during the past 20"
+12 WRITE !,"months, with at least one pregnancy-related visit during the report"
+13 WRITE !,"period, with age and visit information. Displays community, age, and"
+14 WRITE !,"visit data, and codes."
+15 WRITE !,"Age on the patient list is calculated as of June 30."
End DoDot:1
+16 WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"AGE"
+17 WRITE !?5,"VISIT DATE",?20,"DX/SVC CD",?30,"TRIMESTER",?41,"SRV CAT",?49,"CLINIC",?65,"LOCATION"
+18 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+19 SET BUDP=1
+20 QUIT
+21 ;
S(V) ;
+1 SET BUDDECNT=BUDDECNT+1
+2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
+3 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 ;----------
TRIM(V) ;any trimester code on this visit?
+1 NEW X,Y,Z,T1,T2,T3
+2 SET Z=""
+3 SET T1=$ORDER(^ATXAX("B","BGP PREGNANCY TRI 1 DXS",0))
+4 SET T2=$ORDER(^ATXAX("B","BGP PREGNANCY TRI 2 DXS",0))
+5 SET T3=$ORDER(^ATXAX("B","BGP PREGNANCY TRI 3 DXS",0))
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X!(Z]"")
QUIT
Begin DoDot:1
+7 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
+8 IF $$ICD^ATXCHK(Y,T1,9)
SET Z="1ST"
QUIT
+9 IF $$ICD^ATXCHK(Y,T2,9)
SET Z="2ND"
QUIT
+10 IF $$ICD^ATXCHK(Y,T3,9)
SET Z="3RD"
QUIT
End DoDot:1
+11 IF Z]""
QUIT Z
+12 QUIT "UNK"
PRES(P,TAX,BD,ED,NDC) ;EP
+1 ;GO THROUGH 52 FOR PATIENT
+2 SET NDC=$GET(NDC)
+3 NEW BUDD,G,Z,R,D,E,T,F,I,BUDMEDS1,Y,%,K,V,N,A,NDCT
+4 ;S BDMD=$$FMADD^XLFDT(ED,-(6*31)) ;DATE OF EXPIRATION NEEDS TO BE GREATER THAN THIS AND DAYS SUPPLY * REFILLS NEEDS TO BE GREATER THAN THIS ADDED TO ISSUE DATE
+5 SET Z=0
SET G=""
FOR
SET Z=$ORDER(^PS(55,P,"P",Z))
IF Z'=+Z!(G="X")
QUIT
Begin DoDot:1
+6 SET R=$PIECE(^PS(55,P,"P",Z,0),U,1)
+7 ;bad xref
IF '$DATA(^PSRX(R,0))
QUIT
+8 ;not an E-PRES
IF $EXTRACT($PIECE(^PSRX(R,0),U,1))'="X"
QUIT
+9 SET D=$PIECE(^PSRX(R,0),U,6)
+10 ;no drug??
IF 'D
QUIT
+11 SET N=$PIECE($GET(^PSDRUG(D,2)),U,4)
+12 SET A=0
+13 ;a drug we care about
IF $DATA(^ATXAX(TAX,21,"B",D))
SET A=1
+14 IF 'A
IF N]""
IF NDC
IF $DATA(^ATXAX(NDC,21,"B",N))
SET A=1
+15 IF 'A
QUIT
+16 SET E=$PIECE($GET(^PSRX(R,2)),U,6)
+17 ;expires too soon
IF E
IF E<BD
QUIT
+18 ;DAYS SUPPLY
SET Y=$PIECE(^PSRX(R,0),U,8)
+19 ;# REFILLS
SET F=$PIECE(^PSRX(R,0),U,9)
+20 ;total days supply
SET T=Y*(F+1)
+21 ;ISSUE DATE
SET I=$PIECE(^PSRX(R,0),U,13)
+22 ;issued after report period
IF I>ED
QUIT
+23 ;days supply doesn't get to date
IF $$FMADD^XLFDT(I,T)<BD
QUIT
+24 SET G=$PIECE(^PSDRUG(D,0),U,1)_U_$$DATE^BUDHUTL1(I)_U_I
End DoDot:1
+25 IF G]""
QUIT G
+26 ;NOW CHECK FOR E H R OUTSIDE MED IN V MED IN PAST 10 YEARS
EHROUT ;
+1 ;any EHR outside meds?
+2 KILL BUDMEDS1
SET K=0
SET R=""
+3 SET BD=$$FMADD^XLFDT(BD,-(10*365))
+4 ;S X=P_"^ALL MEDS ["_$P(^ATXAX(TAX,0),U,1)_";DURING "_$$FMADD^XLFDT(ED,-3650)_"-"_ED S E=$$START1^APCLDF(X,"BDMMEDS1(")
+5 SET NDCT=""
+6 IF NDC
SET NDCT=$PIECE(^ATXAX(NDC,0),U,1)
+7 DO GETMEDS^BUDHUTL2(P,BD,ED,$PIECE(^ATXAX(TAX,0),U),NDCT,,,.BUDMEDS1)
+8 IF '$DATA(BUDMEDS1)
QUIT ""
+9 SET X=0
FOR
SET X=$ORDER(BUDMEDS1(X))
IF X'=+X!(R]"")
QUIT
SET Y=+$PIECE(BUDMEDS1(X),U,4)
Begin DoDot:1
+10 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+11 ;NOT AN EHR OUTSIDE MED
IF $PIECE($GET(^AUPNVMED(Y,11)),U,8)=""
QUIT
+12 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+13 ;discontinued date
SET %=$PIECE(^AUPNVMED(Y,0),U,8)
+14 ;if discontinued before 6M of report period
IF %]""
IF %<BD
QUIT
+15 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+16 IF 'V
QUIT
+17 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+18 SET R=$$VAL^XBDIQ1(9000010.14,Y,.01)_" (EHR OUTSIDE)"_U_$$DATE^BUDHUTL1($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))_U_$$VD^APCLV(V)
End DoDot:1
+19 QUIT R
