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

BUDDRP6W.m

Go to the documentation of this file. 
  1. BUDDRP6W ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2016 4:03 PM ;
  1.  ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
  1.  ;
  1.  ;
  1.  ;
  1. ROTACONT(P,C,ED) ;EP - ANALPHYLAXIS/IMMUNE DEF
  1.  NEW X
  1.  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
  1.  .S R=$P(^BIPC(X,0),U,3)
  1.  .Q:R=""
  1.  .Q:'$D(^BICONT(R,0))
  1.  .S D=$P(^BIPC(X,0),U,4)
  1.  .Q:D=""
  1.  .I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
  1.  .I $P(^BICONT(R,0),U,1)["Immune" S G=D_U_$P(^BICONT(R,0),U,1)
  1.  .I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"
  1.  Q G
  1.  ;
  1. PRGA ;EP
  1.  W:$D(IOF) @IOF
  1.  W !,$$CTR($$LOC,80)
  1.  W !,$$CTR("UDS 2016",80)
  1.  W !!,"Prenatal Patients by Age (Table 6B)",!
  1.  D GENI^BUDDRP6I
  1.  D PAUSE^BUDDRP6I
  1.  W !!,"This report provides a list of patients by age that had pregnancy-related"
  1.  W !,"visits during the past 20 months, with at least one pregnancy-related visit"
  1.  W !,"during the report period."
  1.  W !
  1.  Q
  1. PRGAL ;EP
  1.  S BUDP=0,BUDQUIT=0,BUDTOT=0
  1.  D PRGAH Q:BUDQUIT
  1.  I '$D(^XTMP("BUDDRP6B",BUDJ,BUDH,"PRGA")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
  1.  S BUDAB="Less than 15 Years" D PRGAL1
  1.  I BUDQUIT G PRGALX
  1.  S BUDAB="Ages 15-19" D PRGAL1
  1.  I BUDQUIT G PRGALX
  1.  S BUDAB="Ages 20-24" D PRGAL1
  1.  I BUDQUIT G PRGALX
  1.  S BUDAB="Ages 25-44" D PRGAL1
  1.  I BUDQUIT G PRGALX
  1.  S BUDAB="Ages 45 and Over" D PRGAL1
  1.  I BUDQUIT G PRGALX
  1.  I BUDROT="P",$Y>(IOSL-3) D PRGAH G:BUDQUIT PRGALX
  1.  I BUDROT="P" W !!,"TOTAL PREGNANT PATIENTS: ",BUDTOT,!
  1.  I BUDROT="D" D S(),S("TOTAL PREGNANT PATIENTS: "_BUDTOT)
  1. PRGALX ;
  1.  Q
  1. PRGAL1 ;
  1.  I BUDROT="P" I $Y>(IOSL-7) D PRGAH Q:BUDQUIT
  1.  I BUDROT="P" W !,BUDAB,!
  1.  I BUDROT="D" D S(),S(BUDAB),S()
  1.  S BUDSTOT=0
  1.  S BUDA=0 F  S BUDA=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA)) Q:BUDA'=+BUDA!(BUDQUIT)  D
  1.  .S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME)) Q:BUDNAME=""!(BUDQUIT)  D
  1.  ..S BUDCCOM="" F  S BUDCCOM=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D
  1.  ....I BUDROT="P" I $Y>(IOSL-3) D PRGAH Q:BUDQUIT
  1.  ....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),!
  1.  ....S BUDSTOT=BUDSTOT+1,BUDTOT=BUDTOT+1
  1.  ....S BUDALL=^XTMP("BUDDRP6B",BUDJ,BUDH,"PRGA",BUDAB,BUDA,BUDNAME,BUDCCOM,DFN)
  1.  ....F BUDX=1:1 S BUDV=$P(BUDALL,U,BUDX) Q:BUDV=""!(BUDQUIT)  D
  1.  .....I BUDROT="P" I $Y>(IOSL-3) D PRGAH Q:BUDQUIT
  1.  .....I $E(BUDV)="P",BUDROT="P" W ?5,BUDV,! Q  ;PROB LIST
  1.  .....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
  1.  .....S V=$P(BUDV,"|"),C=$P(BUDV,"|",2) S T=$$TRIM(V)
  1.  .....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),!
  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_BUDCCOM_U_$$AGE^AUPNPAT(DFN,BUDCCAD) D
  1.  ......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)
  1.  I BUDROT="P" W !,"Sub-Total ",BUDAB,":  ",BUDSTOT,!
  1.  I BUDROT="D" D S("Sub-Total "_BUDAB_":  "_BUDSTOT),S()
  1.  Q
  1. PRGAHD ;delimited header
  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, Sections A & B, Pregnant Patients")
  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(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)
  1.  D S()
  1.  D S("List of all patients with pregnancy-related visits during the past 20")
  1.  D S("months, with at least one pregnancy-related visit during the report")
  1.  D S("period, with age and visit information.  Displays community, age, and")
  1.  D S("visit data, and codes.")
  1.  D S("Age is calculated as of June 30.")
  1.  D S()
  1.  D S("PATIENT NAME^HRN^COMMUNITY^AGE^VISIT DATE^DX/SVC CD^TRIMESTER^SVC CAT^CLINIC^LOCATION")
  1.  Q
  1. PRGAH ;
  1.  I BUDROT="D" D PRGAHD Q
  1.  G:'BUDGPG PRGAH1
  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. PRGAH1 ;
  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, Sections A & B, Pregnant Patients",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 !,"List of all patients with pregnancy-related visits during the past 20"
  1.  .W !,"months, with at least one pregnancy-related visit during the report"
  1.  .W !,"period, with age and visit information.  Displays community, age, and"
  1.  .W !,"visit data, and codes."
  1.  .W !,"Age is calculated as of June 30."
  1.  W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"AGE"
  1.  W !?5,"VISIT DATE",?20,"DX/SVC CD",?30,"TRIMESTER",?41,"SRV CAT",?49,"CLINIC",?65,"LOCATION"
  1.  W !,$TR($J("",80)," ","-"),!
  1.  S BUDP=1
  1.  Q
  1.  ;
  1. S(V) ;
  1.  S BUDDECNT=BUDDECNT+1
  1.  S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
  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. TRIM(V) ;any trimester code on this visit?
  1.  NEW X,Y,Z,T1,T2,T3
  1.  S Z=""
  1.  S T1=$O(^ATXAX("B","BGP PREGNANCY TRI 1 DXS",0))
  1.  S T2=$O(^ATXAX("B","BGP PREGNANCY TRI 2 DXS",0))
  1.  S T3=$O(^ATXAX("B","BGP PREGNANCY TRI 3 DXS",0))
  1.  S X=0 F  S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X!(Z]"")  D
  1.  .S Y=$$VALI^XBDIQ1(9000010.07,X,.01)
  1.  .I $$ICD^ATXCHK(Y,T1,9) S Z="1ST" Q
  1.  .I $$ICD^ATXCHK(Y,T2,9) S Z="2ND" Q
  1.  .I $$ICD^ATXCHK(Y,T3,9) S Z="3RD" Q
  1.  I Z]"" Q Z
  1.  Q "UNK"