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

BUD9RPTD.m

Go to the documentation of this file. 
  1. BUD9RPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
  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=""
  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(^BUDNSITE(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(^BUDNCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
  1.  .I BUDCLINC]"",$D(^BUDNCNTL(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(^BUDNCNTL("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(^BUDNTFIV("C",BUDPP,0)) I BUDY="" S BUDLINE=35 G MEDC1
  1.  .S BUDLINE=$O(^BUDNTFIV("AA",BUDPP,""))
  1. MEDC1 .S S=0
  1.  .I $D(^BUDNCNTL(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(^BUDNCNTL("B","DENTAL LINE NUMBERS",0))
  1.  .S S=0
  1.  .I $D(^BUDNCNTL(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(^BUDNCNTL("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(^BUDNCNTL(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(^BUDNCNTL("B","SUBSTANCE LINE NUMBERS",0))
  1.  .S S=0
  1.  .I $D(^BUDNCNTL(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. OTH .;can have only 1 in each category
  1.  .S BUDTIEN=$O(^BUDNTFIV("B",22,0))
  1.  .S S=0
  1.  .I $D(^BUDNTFIV(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(^BUDNCNTL("B","ENABLING LINE NUMBERS",0))
  1.  .S S=0
  1.  .I $D(^BUDNCNTL(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(^BUDNCNTL("B","CLINIC EXCLUSIONS",0))
  1.  .I BUDCLINC]"",$D(^BUDNCNTL(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.  ;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(^BUDNSITE(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(^BUDNSITE(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