BUDCRP6W ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2015 4:03 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
;
;
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
ROTA(P,BDATE,EDATE) ;EP
;check for a contraindication from DOB to 2nd birthday
NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
;now check for evidence of disease
S X=$$LASTDXI^BUDCUTL1(P,"008.61",$$DOB^AUPNPAT(P),EDATE)
I X]"" Q "1^ROTAVIRUS Evidence: "_$P(X,U,2)_" on "_$$DATE^BUDCUTL1($P(X,U,3))
S X=$$LASTDX^BUDCUTL1(P,"BUD ROTA CONTRA DXS",$$DOB^AUPNPAT(P),EDATE)
I X]"" Q "1^ROTAVIRUS Contraindication: "_$P(X,U,2)_" on "_$$DATE^BUDCUTL1($P(X,U,3))
I $$PLCODE^BUDCDU(P,"008.61") Q "1^ROTAVIRUS Evidence: 008.61 on Problem List"
S X=$$PLTAX^BUDCDU(P,"BUD ROTA CONTRA DXS") I X Q "1^ROTAVIRUS Contraindication: "_$P(X,U,2)_" on Problem List"
F BUDZ=119,74,116,122 S X=$$ROTACONT(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^ROTAVIRUS Contraindication IM package: "_$$DATE^BUDCUTL1($P(X,U))_" "_$P(X,U,2)
S G=""
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G) D
.;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.Q:'$$ANAREACT^BUDCRP6C(X) ;quit if anaphylactic is not a reaction/sign/symptom
.I N["NEOMYCIN" S G="1^ROTAVIRUS Contraindiction: "_$$DATE^BUDCUTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
I G]"" Q G
;now get imms and see if there are 3
K BUDC,BUDG,BUDX
K BUDOPV,BUDAPOV
S BUDOPV2=0
ROTAIMM ;get all immunizations
S C="119"
K BUDX D GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
;now get cpt codes
S X=0 F S X=$O(BUDX(X)) Q:X'=+X S BUDOPV(X)=BUDX(X),BUDAPOV(X)=BUDX(X)
;now get cpts
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90681 D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,".")))
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90681 D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,".")))
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BUDOPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDOPV(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BUDOPV=0,X=0 F S X=$O(BUDOPV(X)) Q:X'=+X S BUDOPV=BUDOPV+1
I BUDOPV>1 S Y="1^ROTA 2: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>1 Q Y
I BUDOPV=1 S BUDOPV2=2
;NOW TRY FOR 3 DOSE
K BUDC,BUDG,BUDX
K BUDOPV,BUDAPOV
ROT3IMM ;get all immunizations
S C="74^116^122"
K BUDX D GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
;now get cpt codes
S X=0 F S X=$O(BUDX(X)) Q:X'=+X S BUDOPV(X)=BUDX(X),BUDAPOV(X)=BUDX(X)
;now get cpts
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90680 D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,".")))
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90680 D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,".")))
..S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X D
...S Y=$$VAL^XBDIQ1(9000010.07,X,.01) I Y="008.61" D
....S BUDOPV(9999999-$P(ED,"."))="POV: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="POV: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$P(ED,".")))
S (X,Y)="",C=0 F S X=$O(BUDOPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDOPV(X) Q
.S Y=X
;now count them and see if there are 3 of them
S BUDOPV=0,X=0 F S X=$O(BUDOPV(X)) Q:X'=+X S BUDOPV=BUDOPV+1
I BUDOPV>2 S Y="1^ROTA: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>2 Q Y
S BUDOPV=BUDOPV+BUDOPV2
I BUDOPV>2 S Y="1^ROTA: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>2 Q Y
Q "0^"_(3-BUDOPV)_" ROTAVIRUS"
PRGA ;EP
W:$D(IOF) @IOF
W !,$$CTR($$LOC,80)
W !,$$CTR("UDS 2015",80)
W !!,"Prenatal Patients by Age (Table 6B)",!
D GENI^BUDCRP6I
D PAUSE^BUDCRP6I
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("BUDCRP6B",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("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA)) Q:BUDA'=+BUDA!(BUDQUIT) D
.S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
..S BUDCOM="" F S BUDCOM=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCOM,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(BUDCOM,1,25),?70,$$AGE^AUPNPAT(DFN,BUDCAD),!
....S BUDSTOT=BUDSTOT+1,BUDTOT=BUDTOT+1
....S BUDALL=^XTMP("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCOM,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
.....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_BUDCOM_U_$$AGE^AUPNPAT(DFN,BUDCAD)_U_BUDV D S(X) Q
.....S V=$P(BUDV,"|"),C=$P(BUDV,"|",2)
.....I BUDROT="P" W ?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),".")),?20,C,?33,$P(^AUPNVSIT(V,0),U,7),?41,$E($$CLINIC^APCLV(V,"E"),1,15),?60,$E($$VAL^XBDIQ1(9000010,V,.06),1,19),!
.....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_$$AGE^AUPNPAT(DFN,BUDCAD) D
......S X=X_U_$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),"."))_U_C_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("***** 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, 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(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)
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 is calculated as of June 30.")
D S()
D S("PATIENT NAME^HRN^COMMUNITY^AGE^VISIT DATE^DX OR SVC CD^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 !,"***** 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, 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(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),!
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 is calculated as of June 30."
W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"AGE"
W !?5,"VISIT DATE",?20,"DX OR SVC CD",?33,"SVC CAT",?41,"CLINIC",?60,"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")
;----------
BUDCRP6W ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2015 4:03 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
+4 ;
+5 ;
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
ROTA(P,BDATE,EDATE) ;EP
+1 ;check for a contraindication from DOB to 2nd birthday
+2 NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
+3 ;now check for evidence of disease
+4 SET X=$$LASTDXI^BUDCUTL1(P,"008.61",$$DOB^AUPNPAT(P),EDATE)
+5 IF X]""
QUIT "1^ROTAVIRUS Evidence: "_$PIECE(X,U,2)_" on "_$$DATE^BUDCUTL1($PIECE(X,U,3))
+6 SET X=$$LASTDX^BUDCUTL1(P,"BUD ROTA CONTRA DXS",$$DOB^AUPNPAT(P),EDATE)
+7 IF X]""
QUIT "1^ROTAVIRUS Contraindication: "_$PIECE(X,U,2)_" on "_$$DATE^BUDCUTL1($PIECE(X,U,3))
+8 IF $$PLCODE^BUDCDU(P,"008.61")
QUIT "1^ROTAVIRUS Evidence: 008.61 on Problem List"
+9 SET X=$$PLTAX^BUDCDU(P,"BUD ROTA CONTRA DXS")
IF X
QUIT "1^ROTAVIRUS Contraindication: "_$PIECE(X,U,2)_" on Problem List"
+10 FOR BUDZ=119,74,116,122
SET X=$$ROTACONT(P,BUDZ,EDATE)
IF X]""
QUIT
+11 IF X]""
QUIT "1^ROTAVIRUS Contraindication IM package: "_$$DATE^BUDCUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+12 SET G=""
+13 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+14 ;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
+15 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+16 ;quit if anaphylactic is not a reaction/sign/symptom
IF '$$ANAREACT^BUDCRP6C(X)
QUIT
+17 IF N["NEOMYCIN"
SET G="1^ROTAVIRUS Contraindiction: "_$$DATE^BUDCUTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+18 IF G]""
QUIT G
+19 ;now get imms and see if there are 3
+20 KILL BUDC,BUDG,BUDX
+21 KILL BUDOPV,BUDAPOV
+22 SET BUDOPV2=0
ROTAIMM ;get all immunizations
+1 SET C="119"
+2 KILL BUDX
DO GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
+3 ;now get cpt codes
+4 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDOPV(X)=BUDX(X)
SET BUDAPOV(X)=BUDX(X)
+5 ;now get cpts
+6 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+7 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+8 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90681
Begin DoDot:4
+12 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+14 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90681
Begin DoDot:4
+15 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+17 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+18 IF C=1
SET Y=X
QUIT
+19 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDOPV(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 ;now count them and see if there are 4 of them
+22 SET BUDOPV=0
SET X=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET BUDOPV=BUDOPV+1
+23 IF BUDOPV>1
SET Y="1^ROTA 2: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+24 IF BUDOPV>1
QUIT Y
+25 IF BUDOPV=1
SET BUDOPV2=2
+26 ;NOW TRY FOR 3 DOSE
+27 KILL BUDC,BUDG,BUDX
+28 KILL BUDOPV,BUDAPOV
ROT3IMM ;get all immunizations
+1 SET C="74^116^122"
+2 KILL BUDX
DO GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
+3 ;now get cpt codes
+4 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDOPV(X)=BUDX(X)
SET BUDAPOV(X)=BUDX(X)
+5 ;now get cpts
+6 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+7 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+8 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90680
Begin DoDot:4
+12 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+14 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90680
Begin DoDot:4
+15 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$$VAL^XBDIQ1(9000010.07,X,.01)
IF Y="008.61"
Begin DoDot:4
+18 SET BUDOPV(9999999-$PIECE(ED,"."))="POV: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="POV: "_Y_" on "_$$DATE^BUDCUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+20 IF C=1
SET Y=X
QUIT
+21 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDOPV(X)
QUIT
+22 SET Y=X
End DoDot:1
+23 ;now count them and see if there are 3 of them
+24 SET BUDOPV=0
SET X=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET BUDOPV=BUDOPV+1
+25 IF BUDOPV>2
SET Y="1^ROTA: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+26 IF BUDOPV>2
QUIT Y
+27 SET BUDOPV=BUDOPV+BUDOPV2
+28 IF BUDOPV>2
SET Y="1^ROTA: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+29 IF BUDOPV>2
QUIT Y
+30 QUIT "0^"_(3-BUDOPV)_" ROTAVIRUS"
PRGA ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC,80)
+3 WRITE !,$$CTR("UDS 2015",80)
+4 WRITE !!,"Prenatal Patients by Age (Table 6B)",!
+5 DO GENI^BUDCRP6I
+6 DO PAUSE^BUDCRP6I
+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("BUDCRP6B",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("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA))
IF BUDA'=+BUDA!(BUDQUIT)
QUIT
Begin DoDot:1
+6 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:2
+7 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+8 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCOM,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(BUDCOM,1,25),?70,$$AGE^AUPNPAT(DFN,BUDCAD),!
+11 SET BUDSTOT=BUDSTOT+1
SET BUDTOT=BUDTOT+1
+12 SET BUDALL=^XTMP("BUDCRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCOM,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 IF $EXTRACT(BUDV)="P"
IF BUDROT="P"
WRITE ?5,BUDV,!
QUIT
+16 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_BUDCOM_U_$$AGE^AUPNPAT(DFN,BUDCAD)_U_BUDV
DO S(X)
QUIT
+17 SET V=$PIECE(BUDV,"|")
SET C=$PIECE(BUDV,"|",2)
+18 IF BUDROT="P"
WRITE ?5,$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),".")),?20,C,?33,$PIECE(^AUPNVSIT(V,0),U,7),?41,$EXTRACT($$CLINIC^APCLV(V,"E"),1,15),?60,$EXTRACT($$VAL^XBDIQ1(9000010,V,.06),1,19),!
+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_BUDCOM_U_$$AGE^AUPNPAT(DFN,BUDCAD)
Begin DoDot:6
+20 SET X=X_U_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))_U_C_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("***** 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, 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(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDCEN)=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 is calculated as of June 30.")
+15 DO S()
+16 DO S("PATIENT NAME^HRN^COMMUNITY^AGE^VISIT DATE^DX OR SVC CD^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 !,"***** 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, 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(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDCEN)=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 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 OR SVC CD",?33,"SVC CAT",?41,"CLINIC",?60,"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 ;----------
