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

APCLCAR1.m

Go to the documentation of this file. 
  1. APCLCAR1 ; IHS/CMI/LAB - calif area GPRA ; 
  1.  ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
  1.  ;
  1.  ;
  1. PROC ;EP - called from XBDBQUE
  1.  S APCLJ=$J,APCLH=$H
  1.  K ^XTMP("APCLCAR",APCLJ,APCLH),^XTMP("APCLCARUNCAT",APCLJ,APCLH)
  1.  D XTMP^APCLOSUT("APCLCAR","CALIF STATE ANNUAL REPORT")
  1.  K ^TMP($J,"PATIENTS19"),APCLRACE,APCLAGEG,APCLINC,APCLSEX,APCLETH,APCLS4
  1.  S (APCLCNT,APCLTOTR,APCLSPE1,APCLSPE2,APCLNCPT,APCLTOTV,APCLNPRV,APCLTO25)=0
  1.  S APCLOD=APCLBD
  1.  F  S APCLOD=$O(^AUPNVSIT("B",APCLOD)) Q:APCLOD=""!($E(APCLOD,1,3)>$E(APCLED,1,3))  D
  1.  .S APCLVSIT=0 F  S APCLVSIT=$O(^AUPNVSIT("B",APCLOD,APCLVSIT)) Q:APCLVSIT'=+APCLVSIT  D
  1.  ..Q:'$D(^AUPNVSIT(APCLVSIT,0))
  1.  ..S APCLV0=^AUPNVSIT(APCLVSIT,0)
  1.  ..Q:$P(APCLV0,U,11)
  1.  ..Q:'$P(APCLV0,U,9)
  1.  ..Q:$P(APCLV0,U,5)=""  ;no patient
  1.  ..Q:$$DEMO^APCLUTL($P(APCLV0,U,5),$G(APCLDEMO))
  1.  ..I $P(APCLV0,U,6)="" Q  ;no location entered???
  1.  ..I $O(APCLLOCT(0)),'$D(APCLLOCT($P(APCLV0,U,6))) Q  ;not a location of interest
  1.  ..Q:'$D(^AUPNVPRV("AD",APCLVSIT))
  1.  ..Q:$$PRIMPROV^APCLV(APCLVSIT,"D")=""
  1.  ..Q:$$PRIMPROV^APCLV(APCLVSIT,"F")=""
  1.  ..Q:'$D(^AUPNVPOV("AD",APCLVSIT))
  1.  ..S APCLPOV=$$PRIMPOV^APCLV(APCLVSIT,"C") Q:APCLPOV=""
  1.  ..Q:$E(APCLPOV)="."
  1.  ..Q:$E(APCLPOV)="E"
  1.  ..Q:$$CLINIC^APCLV(APCLVSIT,"C")=11  ;NOT HOME CARE PER NATALIE
  1.  ..Q:"ICTNEDX"[$P(APCLV0,U,7)  ;ignore chart rev, tele, not found, x and ancillary, in hosp
  1.  ..Q:"CV"[$P(APCLV0,U,3)  ;ignore contract and va type visits
  1.  ..S DFN=$P(APCLV0,U,5)
  1.  ..D SECT2 ;do section 2, line 51-65
  1.  ..I APCLPPPP D
  1.  ...D SECT4
  1.  ...D SECT5^APCLCAR2
  1. RACE ..;
  1.  ..I '$D(^TMP($J,"PATIENTS19",DFN)) S ^TMP($J,"PATIENTS19",DFN)="" S APCLRACE(10)=$G(APCLRACE(10))+1 D
  1.  ...;tally race
  1.  ...S X=$P(^DPT(DFN,0),U,6) I 'X S APCLRACE(9)=$G(APCLRACE(9))+1
  1.  ...I X S Y=$$UP^XLFSTR($P(^DIC(10,X,0),U,2)),X=$$UP^XLFSTR($P(^DIC(10,X,0),U,1)) D
  1.  ....I Y=3!(Y="Z")!(Y="AIAN") S APCLRACE(3)=$G(APCLRACE(3))+1 Q
  1.  ....I Y="A"!(Y=5)!(Y="H") S APCLRACE(4)=$G(APCLRACE(4))+1 Q
  1.  ....I Y="B"!(Y=2)!(Y=4) S APCLRACE(2)=$G(APCLRACE(2))+1 Q
  1.  ....I Y="W"!(Y=1)!(Y=6) S APCLRACE(1)=$G(APCLRACE(1))+1 Q
  1.  ....I Y="U"!(Y=7)!(Y="D") S APCLRACE(9)=$G(APCLRACE(9))+1 Q
  1.  ....I X["WHITE" S APCLRACE(1)=$G(APCLRACE(1))+1 Q
  1.  ....I X["BLACK" S APCLRACE(2)=$G(APCLRACE(2))+1 Q
  1.  ....I X["NATIVE" S APCLRACE(3)=$G(APCLRACE(3))+1 Q
  1.  ....I X["ASIAN" S APCLRACE(4)=$G(APCLRACE(4))+1 Q
  1.  ....I X["PACIFIC ISLANDER" S APCLRACE(4)=$G(APCLRACE(4))+1 Q
  1.  ....I X["FILIPINO" S APCLRACE(4)=$G(APCLRACE(4))+1 Q
  1.  ....I X["HISPANIC" S APCLRACE(1)=$G(APCLRACE(1))+1 Q
  1.  ....S APCLRACE(9)=$G(APCLRACE(9))+1
  1.  ....Q
  1. ETH ...;ETHNICITY
  1.  ...S Z=0,E="" F  S Z=$O(^DPT(DFN,.06,Z)) Q:Z'=+Z!(E]"")  D  I E]"" G AGE
  1.  ....S E=$P($G(^DPT(DFN,.06,Z,0)),U)
  1.  ....Q:E=""
  1.  ....S E=$P($G(^DIC(10.2,E,0)),U,1)
  1.  ....I E="HISPANIC OR LATINO" S APCLRACE(11)=$G(APCLRACE(11))+1 Q
  1.  ....S APCLRACE(12)=$G(APCLRACE(12))+1
  1.  ...S X=$P(^DPT(DFN,0),U,6) S:X X=$P(^DIC(10,X,0),U) D
  1.  ....I X="" S APCLETH(13)=$G(APCLETH(13))+1 Q
  1.  ....I X["HISPANIC" S APCLETH(11)=$G(APCLETH(11))+1 Q
  1.  ....S APCLETH(12)=$G(APCLETH(12))+1
  1. AGE ...;tally age
  1.  ...S AGE=$$AGE^AUPNPAT(DFN,($E(APCLBD,1,3)_"0630"))
  1.  ...S SEX=$P(^DPT(DFN,0),U,2),SEX=$S(SEX="M":1,1:2),APCLSEX(SEX)=$G(APCLSEX(SEX))+1
  1.  ...S G=$$AGEG(AGE),$P(APCLAGEG(G),U,SEX)=$P($G(APCLAGEG(G)),U,SEX)+1
  1. INC ...;
  1.  ...S N=$P(^AUPNPAT(DFN,0),U,35),I=$P(^AUPNPAT(DFN,0),U,36)
  1.  ...I N<1!(I="") S APCLINC("UNKNOWN/UNREPORTED")=$G(APCLINC("UNKNOWN/UNREPORTED"))+1 Q
  1.  ...I N<11 D  Q
  1.  ....S X=$O(^APCLCIL("B",N,0)),L=$P(^APCLCIL(X,0),U,2),H=$P(^APCLCIL(X,0),U,3)
  1.  ....I I'>L S APCLINC("UNDER 100%")=$G(APCLINC("UNDER 100%"))+1 Q
  1.  ....I I'<H S APCLINC("ABOVE 200%")=$G(APCLINC("ABOVE 200%"))+1 Q
  1.  ....S APCLINC("100-200%")=$G(APCLINC("100-200%"))+1
  1.  ...I N>10 D
  1.  ....S X=$O(^APCLCIL("B",10,0)),L=$P(^APCLCIL(X,0),U,2),H=$P(^APCLCIL(X,0),U,3)
  1.  ....F %=10:1:N S L=L+2820,H=H+2820
  1.  ....I I'>L S APCLINC("UNDER 100%")=$G(APCLINC("UNDER 100%"))+1 Q
  1.  ....I I'<H S APCLINC("ABOVE 200%")=$G(APCLINC("ABOVE 200%"))+1 Q
  1.  ....S APCLINC("100-200%")=$G(APCLINC("100-200%"))+1
  1.  ..S AGE=$$AGE^AUPNPAT(DFN,($E(APCLBD,1,3)_"0630"))
  1.  ..S G=0
  1.  K ^TMP($J)
  1.  Q
  1.  ;
  1. P(D,A) ;disc, age
  1.  I A>19,D=1 Q 1
  1.  I A>19,D=2 Q 2
  1.  I A>19,D=3 Q 3
  1.  I A>19,D=4 Q 4
  1.  I A<20&(A>12),D=1 Q 5
  1.  I A<20&(A>12),D=2 Q 6
  1.  I A<20&(A>12),D=3 Q 7
  1.  I A<20&(A>12),D=4 Q 8
  1.  I A<13,D=1 Q 9
  1.  I A<13,D=2 Q 10
  1.  I A<13,D=3 Q 11
  1.  I A<13,D=4 Q 12
  1.  Q ""
  1. AGEG(A) ;
  1.  I A<1 Q "Under 1 year"
  1.  I A>0&(A<5) Q "1-4 years"
  1.  I A>4&(A<13) Q "5-12 years"
  1.  I A>12&(A<15) Q "13-14 years"
  1.  I A>14&(A<20) Q "15-19 years"
  1.  I A>19&(A<35) Q "20-34 years"
  1.  I A>34&(A<45) Q "35-44 years"
  1.  I A>44&(A<65) Q "45-64 years"
  1.  I A>64 Q "65 and over"
  1.  Q ""
  1. S(J,H,N,P,V) ;
  1.  S $P(^XTMP("APCLCAR",J,H,N),U,P)=$P($G(^XTMP("APCLCAR",J,H,N)),U,P)+V
  1.  Q
  1. SECT4 ;primary pov
  1.  S APCLS4(25)=$G(APCLS4(25))+1
  1.  I $D(^AUPNVDEN("AD",APCLVSIT)) S APCLS4(19)=$G(APCLS4(19))+1 Q
  1.  I $$CLINIC^APCLV(APCLVSIT,"C")=56 S APCLS4(19)=$G(APCLS4(19))+1 Q
  1.  I $E(APCLPOV)="V",$E(APCLPOV,2,3)<90 S APCLS4(18)=$G(APCLS4(18))+1 Q
  1.  I $E(APCLPOV)="V" S APCLS4(21)=$G(APCLS4(21))+1 Q
  1.  I $E(APCLPOV,1,3)<140 S APCLS4(1)=$G(APCLS4(1))+1 Q
  1.  I $E(APCLPOV,1,3)<240 S APCLS4(2)=$G(APCLS4(2))+1 Q
  1.  I $E(APCLPOV,1,3)<280 S APCLS4(3)=$G(APCLS4(3))+1 Q
  1.  I $E(APCLPOV,1,3)<290 S APCLS4(4)=$G(APCLS4(4))+1 Q
  1.  I $E(APCLPOV,1,3)<320 S APCLS4(5)=$G(APCLS4(5))+1 Q
  1.  I $E(APCLPOV,1,3)<390 S APCLS4(6)=$G(APCLS4(6))+1 Q
  1.  I $E(APCLPOV,1,3)<460 S APCLS4(7)=$G(APCLS4(7))+1 Q
  1.  I $E(APCLPOV,1,3)<520 S APCLS4(8)=$G(APCLS4(8))+1 Q
  1.  I $E(APCLPOV,1,3)<580,$E(APCLPOV,1,3)>529.99 S APCLS4(9)=$G(APCLS4(9))+1 Q
  1.  I $E(APCLPOV,1,3)<630 S APCLS4(10)=$G(APCLS4(10))+1 Q
  1.  I $E(APCLPOV,1,3)<680 S APCLS4(11)=$G(APCLS4(11))+1 Q
  1.  I $E(APCLPOV,1,3)<710 S APCLS4(12)=$G(APCLS4(12))+1 Q
  1.  I $E(APCLPOV,1,3)<740 S APCLS4(13)=$G(APCLS4(13))+1 Q
  1.  I $E(APCLPOV,1,3)<760 S APCLS4(14)=$G(APCLS4(14))+1 Q
  1.  I $E(APCLPOV,1,3)<780 S APCLS4(15)=$G(APCLS4(15))+1 Q
  1.  I $E(APCLPOV,1,3)<800 S APCLS4(16)=$G(APCLS4(16))+1 Q
  1.  I $E(APCLPOV,1,3)<1000 S APCLS4(17)=$G(APCLS4(17))+1 Q
  1.  S APCLS4(21)=$G(APCLS4(21))+1 ;W "OTHER: ",APCLPOV
  1.  Q
  1. SECT2 ;
  1.  S APCLTOTV=APCLTOTV+1
  1.  S X=$$PRIMPROV^APCLV(APCLVSIT,"F")
  1.  Q:X=""
  1.  S APCLPPPP=1
  1.  I APCL60T,$D(^ATXAX(APCL60T,21,"B",X)) D S(APCLJ,APCLH,2,1,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL61T,$D(^ATXAX(APCL61T,21,"B",X)) D S(APCLJ,APCLH,2,2,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL62T,$D(^ATXAX(APCL62T,21,"B",X)) D S(APCLJ,APCLH,2,3,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL63T,$D(^ATXAX(APCL63T,21,"B",X)) D S(APCLJ,APCLH,2,4,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL64T,$D(^ATXAX(APCL64T,21,"B",X)) D S(APCLJ,APCLH,2,5,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL65T,$D(^ATXAX(APCL65T,21,"B",X)) D S(APCLJ,APCLH,2,6,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL66T,$D(^ATXAX(APCL66T,21,"B",X)) D S(APCLJ,APCLH,2,7,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL67T,$D(^ATXAX(APCL67T,21,"B",X)) D S(APCLJ,APCLH,2,8,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL68T,$D(^ATXAX(APCL68T,21,"B",X)) D S(APCLJ,APCLH,2,9,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL69T,$D(^ATXAX(APCL69T,21,"B",X)) D S(APCLJ,APCLH,2,10,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL70T,$D(^ATXAX(APCL70T,21,"B",X)) D S(APCLJ,APCLH,2,11,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL74T,$D(^ATXAX(APCL74T,21,"B",X)) D S(APCLJ,APCLH,2,12,1),S(APCLJ,APCLH,2,14,1) S APCLTO25=APCLTO25+1 Q
  1.  S APCLPPPP=0
  1.  I APCL80T,$D(^ATXAX(APCL80T,21,"B",X)) D S(APCLJ,APCLH,2,15,1),S(APCLJ,APCLH,2,30,1) S APCLTO25=APCLTO25+1 Q
  1.  I APCL81T,$D(^ATXAX(APCL81T,21,"B",X)) D S(APCLJ,APCLH,2,16,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL82T,$D(^ATXAX(APCL82T,21,"B",X)) D S(APCLJ,APCLH,2,17,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL83T,$D(^ATXAX(APCL83T,21,"B",X)) D S(APCLJ,APCLH,2,18,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL84T,$D(^ATXAX(APCL84T,21,"B",X)) D S(APCLJ,APCLH,2,19,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL85T,$D(^ATXAX(APCL85T,21,"B",X)) D S(APCLJ,APCLH,2,20,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL86T,$D(^ATXAX(APCL86T,21,"B",X)) D S(APCLJ,APCLH,2,21,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL87T,$D(^ATXAX(APCL87T,21,"B",X)) D S(APCLJ,APCLH,2,22,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL88T,$D(^ATXAX(APCL88T,21,"B",X)) D S(APCLJ,APCLH,2,23,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL89T,$D(^ATXAX(APCL89T,21,"B",X)) D S(APCLJ,APCLH,2,24,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL90T,$D(^ATXAX(APCL90T,21,"B",X)) D S(APCLJ,APCLH,2,25,1),S(APCLJ,APCLH,2,30,1) Q
  1.  I APCL94T,$D(^ATXAX(APCL94T,21,"B",X)) D S(APCLJ,APCLH,2,26,1),S(APCLJ,APCLH,2,30,1) Q
  1.  S APCLNPRV=APCLNPRV+1
  1.  S ^XTMP("APCLCARUNCAT",APCLJ,APCLH,X,$$PRIMPROV^APCLV(APCLVSIT,"N"))=""
  1.  Q
  1. DISC(V) ;
  1.  I '$G(V) Q ""
  1.  NEW D
  1.  S D=$$PRIMPROV^APCLV(V,"D")
  1.  S D=$O(^APCLCPD("B",D,0)) I 'D Q ""
  1.  Q $P(^APCLCPD(D,0),U,2)
  1.  ;