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

BUDBRPTD.m

Go to the documentation of this file. 
  1. BUDBRPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR 05 Oct 2014 5:03 PM ; 
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1.  ;
  1. GETV ;EP - get all visits for this patient and tally in BUDTV
  1.  ;^TMP($J,"VISITS") has all visits
  1.  ;^TMP($J,"VISITSLIST") is visit list 1 in the SRD
  1.  ;^TMP($J,"VISITS35") is used for table 3 and 5
  1.  ;^TMP($J,"VISITS6DX") is used for table 6 dxs and includes 2 visits on same day to same provider
  1.  K ^TMP($J)
  1.  S BUDTV=0,BUDT35V=0,BUDT6V=0,BUDMEDV=0,BUDMEDVI="",BUDLASTV=""
  1.  S A="^TMP($J,""VISITS"",",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BUDBD)_"-"_$$FMTE^XLFDT(BUDED),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"VISITS",1)) Q
  1.  S BUDX=0 F  S BUDX=$O(^TMP($J,"VISITS",BUDX)) Q:BUDX'=+BUDX  S BUDVSIT=$P(^TMP($J,"VISITS",BUDX),U,5) D
  1.  .Q:'$D(^AUPNVSIT(BUDVSIT,0))
  1.  .Q:'$P(^AUPNVSIT(BUDVSIT,0),U,9)
  1.  .Q:$P(^AUPNVSIT(BUDVSIT,0),U,11)
  1.  .S BUDVLOC=$P(^AUPNVSIT(BUDVSIT,0),U,6)
  1.  .Q:BUDVLOC=""
  1.  .Q:'$D(^BUDBSITE(BUDSITE,11,BUDVLOC))  ;not valid location
  1.  .Q:"AHSORMEI"'[$P(^AUPNVSIT(BUDVSIT,0),U,7)
  1.  .S BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")
  1.  .S BUDTIEN=$O(^BUDBCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
  1.  .I BUDCLINC]"",$D(^BUDBCNTL(BUDTIEN,11,"B",BUDCLINC)) Q  ;not a clinic code we want in any table
  1.  .;now eliminate subsequent visits to same provider on same day  = item 4 in SRD visit definition
  1.  .S BUDVDATE=$$VD^APCLV(BUDVSIT)
  1.  .S BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"I")
  1.  .I $P(^AUPNVSIT(BUDVSIT,0),U,7)="I" G SET  ;don't count I visits
  1.  .I '$D(^AUPNVPOV("AD",BUDVSIT)) G SET
  1.  .S S=0
  1.  .I BUDPP]"" D
  1.  ..S D=$P($G(^TMP($J,"SAMEPROV",DFN,BUDVDATE,BUDPP)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already had a visit to this provider on this date
  1.  ..S ^TMP($J,"SAMEPROV",DFN,BUDVDATE,BUDPP)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
  1.  .Q:S  ;quit if already had a visit to this provider
  1.  .S BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"D")
  1.  .I BUDPP="" G SET
  1. MEDC .;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
  1.  .S S=0
  1.  .S BUDTIEN=$O(^BUDBCNTL("B","MEDICAL CARE LINE NUMBERS",0))
  1.  .;S BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"D")
  1.  .I $E($$VAL^XBDIQ1(9000010,BUDVSIT,.06),1,3)="CHS",BUDPP=15 S BUDLINE=2 G MEDC1
  1.  .S BUDY=$O(^BUDBTFIV("C",BUDPP,0)) I BUDY="" S BUDLINE=35 G MEDC1
  1.  .S BUDLINE=$O(^BUDBTFIV("AA",BUDPP,""))
  1. MEDC1 .S S=0
  1.  .I $D(^BUDBCNTL(BUDTIEN,11,"B",BUDLINE)) D
  1.  ..S D=$P($G(^TMP($J,"MEDCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a medical care visit on this date
  1.  ..S ^TMP($J,"MEDCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
  1.  ..S BUDMEDV=BUDMEDV+1,BUDMEDVI=BUDVSIT
  1.  .Q:S  ;don't count this one, already counted one medical
  1. DENT .;NOW CHECK FOR DENTAL CARE
  1.  .S S=0
  1.  .S BUDTIEN=$O(^BUDBCNTL("B","DENTAL LINE NUMBERS",0))
  1.  .S S=0
  1.  .I $D(^BUDBCNTL(BUDTIEN,11,"B",BUDLINE)) D
  1.  ..S D=$P($G(^TMP($J,"DENTCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a DENTAL care visit on this date
  1.  ..S ^TMP($J,"DENTCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
  1.  .Q:S  ;don't count this one, already counted one DENTAL
  1. MH .;NOW CHECK FOR MH CARE
  1.  .S S=0
  1.  .S BUDTIEN=$O(^BUDBCNTL("B","MENTAL HEALTH LINE NUMBERS",0))
  1.  .S P=$$PRIMPOV^APCLV(BUDVSIT,"C")
  1.  .I $E(P,1,3)=303!($E(P,1,3)="304")!($E(P,1,3)="305") G SUB
  1.  .S S=0
  1.  .I $D(^BUDBCNTL(BUDTIEN,11,"B",BUDLINE)) D
  1.  ..S D=$P($G(^TMP($J,"MHCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a MH care visit on this date
  1.  ..S ^TMP($J,"MHCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
  1.  .Q:S  ;don't count this one, already counted one MH
  1. SUB .;
  1.  .S S=0
  1.  .S BUDTIEN=$O(^BUDBCNTL("B","SUBSTANCE LINE NUMBERS",0))
  1.  .S S=0
  1.  .I $D(^BUDBCNTL(BUDTIEN,11,"B",BUDLINE)) D
  1.  ..S D=$P($G(^TMP($J,"SUBCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a SUB care visit on this date
  1.  ..S ^TMP($J,"SUBCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
  1.  .Q:S  ;don't count this one, already counted one SUBSTANCE
  1. VISION .;
  1.  .S S=0
  1.  .S BUDTIEN=$O(^BUDBCNTL("B","VISION LINE NUMBERS",0))
  1.  .S S=0
  1.  .I $D(^BUDBCNTL(BUDTIEN,11,"B",BUDLINE)) D
  1.  ..S D=$P($G(^TMP($J,"VISIONCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a VISION care visit on this date
  1.  ..S ^TMP($J,"VISIONCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
  1.  .Q:S  ;don't count this one, already counted one VISION
  1. OTH .;can have only 1 in each category
  1.  .S BUDTIEN=$O(^BUDBTFIV("B",22,0))
  1.  .S S=0
  1.  .I $D(^BUDBTFIV(BUDTIEN,11,"B",BUDPP)) D
  1.  ..S D=$P($G(^TMP($J,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPP)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q
  1.  ..S ^TMP($J,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPP)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
  1.  .Q:S
  1. ENAB .;NOW CHECK FOR ENABLING
  1.  .S S=0
  1.  .S BUDTIEN=$O(^BUDBCNTL("B","ENABLING LINE NUMBERS",0))
  1.  .S S=0
  1.  .I $D(^BUDBCNTL(BUDTIEN,11,"B",BUDLINE)) D
  1.  ..S D=$P($G(^TMP($J,"ENABCARE",DFN,BUDVDATE,BUDVLOC,BUDPP)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a ENABLING care visit on this date
  1.  ..S ^TMP($J,"ENABCARE",DFN,BUDVDATE,BUDVLOC,BUDPP)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
  1.  .Q:S   ;don't count this one, already counted onE ENABLING
  1. SET .S BUDTV=BUDTV+1
  1.  .S ^TMP($J,"VISITSLIST",BUDVSIT)=""  ;USED IN TABLE 6A SERVICES ONLY
  1.  .;NOW get all for table 3A, 3B, 5 AND 6 dxs, same list but include duplicates
  1.  .I '$D(^AUPNVPOV("AD",BUDVSIT)) Q
  1.  .;must have a primary dx other than .9999
  1.  .S Y=$$PRIMPOV^APCLV(BUDVSIT,"C") I Y=".9999" Q
  1.  .;the above make it a "complete" visit
  1.  .S BUDTIEN=$O(^BUDBCNTL("B","CLINIC EXCLUSIONS",0))
  1.  .I BUDCLINC]"",$D(^BUDBCNTL(BUDTIEN,11,"B",BUDCLINC)) Q  ;exclude these clinics
  1.  .Q:"EI"[$P(^AUPNVSIT(BUDVSIT,0),U,7)  ;new in 07 to exclude these from tables 3,5
  1.  .Q:BUDPP=""  ;no primary provider
  1.  .S BUDT35V=BUDT35V+1
  1.  .S ^TMP($J,"VISITS356A",BUDVSIT)=""
  1.  .I $$VD^APCLV(BUDLASTV)<$$VD^APCLV(BUDVSIT) S BUDLASTV=BUDVSIT
  1.  ;now get all mamms and paps in date range and count as orphans if at this facility and no mam on that date in pcc
  1.  Q:BUDT35V=0  ;not a patient of interest
  1.  ;Q:'$D(^BWP(DFN))
  1.  S T="MAMMOGRAM SCREENING",T=$O(^BWPN("B",T,0))
  1.  S T1="MAMMOGRAM DX BILAT",T1=$O(^BWPN("B",T1,0))
  1.  S T2="MAMMOGRAM DX UNILAT",T2=$O(^BWPN("B",T2,0))
  1.  I $$VERSION^XPDUTL("BW")<3  D
  1.  .S (G,V)=0 F  S V=$O(^BWPCD("C",DFN,V)) Q:V=""  D
  1.  ..Q:'$D(^BWPCD(BUDVSIT,0))
  1.  ..S D=$P(^BWPCD(BUDVSIT,0),U,12)
  1.  ..S J=$P(^BWPCD(BUDVSIT,0),U,4) I J=T!(J=T1)!(J=T2) D  Q
  1.  ...Q:D<BUDBD
  1.  ...Q:D>BUDED
  1.  ...Q:$P($G(^BWPCD(BUDVSIT,"PCC")),U,1)]""  ;already in pcc
  1.  ...S L=$P(^BWPCD(BUDVSIT,0),U,10)
  1.  ...Q:L=""
  1.  ...Q:'$D(^BUDBSITE(BUDSITE,11,L))  ;not valid location
  1.  ...S ^TMP($J,"MAMMS",V)="WH "_$$VAL^XBDIQ1(9002086.1,V,.04)_U_$$FMTE^XLFDT(D)
  1.  .Q
  1.  ;;E  D
  1.  ;.S T="MAMMOGRAM SCREENING",T=$O(^BWVPDT("B",T,0))
  1.  ;.S T1="MAMMOGRAM DX BILAT",T1=$O(^BWVPDT("B",T1,0))
  1.  ;.S T2="MAMMOGRAM DX UNILAT",T2=$O(^BWVPDT("B",T2,0))
  1.  ;.S D=$$FINDLSTD^BWVPRD(DFN,T_"^"_T1_"^"_T2,BUDBD,BUDED)
  1.  ;.Q:D=0
  1.  ;.Q:D=""
  1.  ;.;check location here
  1.  ;.S ^TMP($J,"MAMMS",1)="WH MAMMOGRAM "_U_$$FMTE^XLFDT(D)_U_D
  1.  S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
  1.  I $$VERSION^XPDUTL("BW")<3  D
  1.  .S (G,BUDVSIT)=0 F  S BUDVSIT=$O(^BWPCD("C",DFN,BUDVSIT)) Q:BUDVSIT=""  D
  1.  ..Q:'$D(^BWPCD(BUDVSIT,0))
  1.  ..S D=$P(^BWPCD(BUDVSIT,0),U,12)
  1.  ..S J=$P(^BWPCD(BUDVSIT,0),U,4) I J=T D  Q
  1.  ...Q:D<BUDBD
  1.  ...Q:D>BUDED
  1.  ...Q:$P($G(^BWPCD(BUDVSIT,"PCC")),U,1)]""  ;already in pcc
  1.  ...S L=$P(^BWPCD(BUDVSIT,0),U,10)
  1.  ...Q:L=""
  1.  ...Q:'$D(^BUDBSITE(BUDSITE,11,L))  ;not valid location
  1.  ...S ^TMP($J,"PAPS",BUDVSIT)="WH PAP SMEAR"_U_$$FMTE^XLFDT(D)
  1.  .Q
  1.  ;E  D
  1.  ;.S T="PAP SMEAR",T=$O(^BWVPDT("B",T,0))
  1.  ;.S D=$$FINDLSTD^BWVPRD(DFN,T,BUDBD,BUDED)
  1.  ;.Q:D=0
  1.  ;.Q:D=""
  1.  ;.;check location here
  1.  ;.S ^TMP($J,"PAPS",1)="WH PAP SMEAR "_U_$$FMTE^XLFDT(D)_U_D
  1.  ;.S ^DIBT(4370,1,DFN)=""
  1.  ;.Q
  1.  Q
  1. TZH ;EP
  1.  G:'BUDGPG TZH1
  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. TZH1 ;
  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: Patient by Zip Code/Insurance",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 W !,"List of all patients with one or more visits during the calendar year."
  1.  I BUDP=0 W !,"Zip code is from patient registration."
  1.  I BUDP=0 W !!,"NOTE:  Patients with a zip code included in the Other Zip Codes category"
  1.  I BUDP=0 W !,"have their zip code value followed by a ""","*",""" (e.g. 87015*)."
  1.  W !!,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"ZIP CODE",?65,"INS"
  1.  W !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"
  1.  S BUDP=1
  1.  W !,$TR($J("",80)," ","-")
  1.  Q
  1. CTR(X,Y) ;EP
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;
  1. WDEL ;EP - write out delimited file 9d
  1.  ;call xbgsave to create output file
  1.  S XBGL="BUDDATA"
  1.  L +^BUDDATA:300 E  W:'$D(ZTQUEUED) "Unable to lock global" Q
  1.  K ^TMP($J,"SUMMARYDEL")
  1.  K ^BUDDATA ;global for saving
  1.  S X="DATE^BILL (A/R)^TRANSACTION TYPE^CREDIT^DEBIT^PRIME BILL AMOUNT^PAYMENT^ADJUSTMENT^ADJUSTMENT CATEGORY^ADJUSTMENT TYPE^A/R ACCOUNT^PATIENT (A/R)^VISIT LOCATION^CLINIC TYPE^DOS BEGIN^BILL TYPE^PRIMARY PROVIDER^"
  1.  S X=X_"HRN^DOB^COMMUNITY"
  1.  S ^BUDDATA(1)=X
  1.  S D=0,C=1 F  S D=$O(^XTMP("BUDARP9DEL",BUDJ,BUDH,D)) Q:D'=+D  D
  1.  .S X=0 F  S X=$O(^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X)) Q:X'=+X  D
  1.  ..S C=C+1 S ^BUDDATA(C)=^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X)
  1.  S XBFLT=1,XBFN=BUDFILE_".txt",XBMED="F",XBTLE="UDS TABLE 9D DELIMITED",XBQ="N",XBF=0
  1.  D ^XBGSAVE
  1.  K XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
  1.  L -^BUDDATA
  1.  K ^BUDDATA ;export global
  1.  Q