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