APCLPP21 ; IHS/CMI/LAB - provider profile ;
;;2.0;IHS PCC SUITE;**7,10**;MAY 14, 2009;Build 88
;
;cmi/anch/maw 9/10/2007 code set versioning in EM
;
START ;
S APCLBT=$H,(APCLDPPT,APCLDPPS,APCLDP2V)=0
K APCLDPPT,APCLDPPS,APCLDP2V
K APCLTCR,APCLTTEL,APCLANY,APCLAMB,APCLDW1,APCLDW2,APCLDW3,APCLDW4,APCLDW5,APCLDW6,APCLDW7,APCLDW8,APCLDW9,APCLDW10,APCLDW11,APCLDW12,APCLDW13,APCLDW14,APCLDW15
;
S Y=0 F S Y=$O(APCLPROV(Y)) Q:Y'=+Y D
.S APCLDPPT(Y)=0,APCLDPPS(Y)=0,APCLDP2V(Y)=0,APCLTCR(Y)=0,APCLTTEL(Y)=0,APCLANY(Y)=0,APCLAMB(Y)=0,APCLDW1(Y)=0,APCLDW2(Y)=0,APCLDW3(Y)=0,APCLDW4(Y)=0,APCLDW5(Y)=0,APCLDW6(Y)=0,APCLDW7(Y)=0,APCLDW8(Y)=0,APCLDW9(Y)=0,APCLDW10(Y)=0
.S APCLDW11(Y)=0,APCLDW12(Y)=0,APCLDW13(Y)=0,APCLDW14(Y)=0,APCLDW15(Y)=0,APCLTOTH(Y)=0,APCLDW51(Y)=0
;
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D PROC
END ;
K ^TMP($J)
D SET^APCLPP2
S APCLET=$H
K APCLCOM,APCLVREC
Q
PROC ;
S APCLYDP=0
Q:'$D(^DPT(DFN,0))
Q:$P(^DPT(DFN,0),U,19) ;merged
I $G(APCLSEAT) Q:'$D(^DIBT(APCLSEAT,1,DFN))
Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
S X=$P(^AUPNPAT(DFN,0),U,14) I X,$D(APCLPROV(X)) S APCLDPPT(X)=$G(APCLDPPT(X))+1,APCLYDP=X
D TALLYV
Q
TALLYV ;
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCLBD)_"-"_$$FMTE^XLFDT(APCLED),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1))
K APCLANY,APCLAMB S Y=0 F S Y=$O(APCLPROV(Y)) Q:Y'=+Y S APCLANY(Y)=0,APCLAMB(Y)=0
S APCLX=0 F S APCLX=$O(^TMP($J,"A",APCLX)) Q:APCLX'=+APCLX S APCLV=$P(^TMP($J,"A",APCLX),U,5) D
.Q:'$D(^AUPNVSIT(APCLV,0))
.Q:'$P(^AUPNVSIT(APCLV,0),U,9)
.Q:$P(^AUPNVSIT(APCLV,0),U,11)
.Q:'$D(^AUPNVPRV("AD",APCLV))
.S (APCLPRIM,G,APCLZ)=0
.F S APCLZ=$O(^AUPNVPRV("AD",APCLV,APCLZ)) Q:APCLZ'=+APCLZ S APCLPRIM=0 I $D(^AUPNVPRV(APCLZ,0)),$D(APCLPROV($P(^AUPNVPRV(APCLZ,0),U))) S APCLPRV=$P(^AUPNVPRV(APCLZ,0),U) S:$P(^AUPNVPRV(APCLZ,0),U,4)="P" APCLPRIM=1 D
..I "EDX"'[$P(^AUPNVSIT(APCLV,0),U,7) S APCLANY(APCLPRV)=APCLANY(APCLPRV)+1
..I $P(^AUPNVSIT(APCLV,0),U,7)="C" S APCLTCR(APCLPRV)=APCLTCR(APCLPRV)+1
..I $P(^AUPNVSIT(APCLV,0),U,7)="T" S APCLTTEL(APCLPRV)=APCLTTEL(APCLPRV)+1
..I $P(^AUPNVSIT(APCLV,0),U,7)="I",$P(^AUPNVSIT(APCLV,0),U,6)=APCLSUH S APCLDW14(APCLPRV)=APCLDW14(APCLPRV)+1
..I $P(^AUPNVSIT(APCLV,0),U,7)="I",$P(^AUPNVSIT(APCLV,0),U,6)'=APCLSUH S APCLDW15(APCLPRV)=APCLDW15(APCLPRV)+1
INP ..;
..I $P(^AUPNVSIT(APCLV,0),U,7)="H",APCLPRIM=1 S APCLDW13(APCLPRV)=APCLDW13(APCLPRV)+1 D
...S APCLEM=$$EM(APCLV) I APCLEM]"" S ^(APCLEM)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","EM",APCLEM)):^(APCLEM)+1,1:1)
...S P=0 F S P=$O(^AUPNVPOV("AD",APCLV,P)) Q:P'=+P S I=$P($G(^AUPNVPOV(P,0)),U) I I D
....I APCLEXCL=1,$D(APCLDXT(I)) Q
....S ^(I)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","INPTDX",I)):^(I)+1,1:1)
...S APCLPOV=0 F S APCLPOV=$O(^AUPNVPRC("AD",APCLV,APCLPOV)) Q:APCLPOV="" D
....S P=$P($G(^AUPNVPRC(APCLPOV,0)),U)
....Q:'P
....S ^(P)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","INPTSURGPROC",P)):^(P)+1,1:1)
AMB ..I "AORS"[$P(^AUPNVSIT(APCLV,0),U,7) S APCLAMB(APCLPRV)=APCLAMB(APCLPRV)+1 D
...S APCLDW10(APCLPRV)=APCLDW10(APCLPRV)+1 ;total amb
...I APCLPRIM S APCLDW11(APCLPRV)=APCLDW11(APCLPRV)+1 D
....S APCLEM=$$EM(APCLV)
....I APCLEM]"" S ^(APCLEM)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","EM",APCLEM)):^(APCLEM)+1,1:1)
....S X=0 F S X=$O(^AUPNVMED("AD",APCLV,X)) Q:X'=+X I $D(^AUPNVMED(X,0)) S Y=$P(^AUPNVMED(X,0),U),Y=$P(^PSDRUG(Y,0),U),^(Y)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","RX",Y)):^(Y)+1,1:1)
....S APCLPOV=0 F S APCLPOV=$O(^AUPNVPRC("AD",APCLV,APCLPOV)) Q:APCLPOV="" D
.....S P=$P($G(^AUPNVPRC(APCLPOV,0)),U)
.....Q:'P
.....S ^(P)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SURGPROC",P)):^(P)+1,1:1)
...I 'APCLPRIM S APCLDW12(APCLPRV)=APCLDW12(APCLPRV)+1
...S APCLSC=$$VAL^XBDIQ1(9000010,APCLV,.07) I APCLSC="" S APCLSC="UNKNOWN"
...S ^(APCLSC)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SC",APCLSC)):^(APCLSC)+1,1:1)
...S APCLLOC=$$VAL^XBDIQ1(9000010,APCLV,.06) I APCLLOC="" S APCLLOC="UNKNOWN"
...S ^(APCLLOC)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOC",APCLLOC)):^(APCLLOC)+1,1:1)
...S P=0 F S P=$O(^AUPNVPOV("AD",APCLV,P)) Q:P'=+P S I=$P($G(^AUPNVPOV(P,0)),U) I I D
....I APCLEXCL=1,$D(APCLDXT(I)) Q
....S ^(I)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","OUTDX",I)):^(I)+1,1:1)
PATED ...;
...S APCLPOV=0 F S APCLPOV=$O(^AUPNVPED("AD",APCLV,APCLPOV)) Q:APCLPOV="" D
....Q:'$D(^AUPNVPED(APCLPOV,0))
....Q:$P(^AUPNVPED(APCLPOV,0),U,5)'=APCLPRV
....S P=$P(^AUPNVPED(APCLPOV,0),U),D=$P(^AUTTEDT(P,0),U)
....S ^(D)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","PATED",D)):^(D)+1,1:1)
S APCLPRV=0 F S APCLPRV=$O(APCLPROV(APCLPRV)) Q:APCLPRV'=+APCLPRV D MORE
Q
MORE ;
I APCLYDP=APCLPRV,APCLANY(APCLPRV)>0 S APCLDPPS(APCLPRV)=APCLDPPS(APCLPRV)+1
I APCLAMB(APCLPRV)>1,$P(^AUPNPAT(DFN,0),U,14)="" S APCLDP2V(APCLPRV)=APCLDP2V(APCLPRV)+1
I APCLANY(APCLPRV)>0 D
.S APCLDW1(APCLPRV)=APCLDW1(APCLPRV)+1
.I APCLYDP=APCLPRV S APCLDW2(APCLPRV)=APCLDW2(APCLPRV)+1
.I APCLYDP'=APCLPRV S APCLDW3(APCLPRV)=APCLDW3(APCLPRV)+1
.I $P(^DPT(DFN,0),U,2)="M" S APCLDW4(APCLPRV)=APCLDW4(APCLPRV)+1
.I $P(^DPT(DFN,0),U,2)="F" S APCLDW5(APCLPRV)=APCLDW5(APCLPRV)+1
.I $P(^DPT(DFN,0),U,2)="U" S APCLDW51(APCLPRV)=APCLDW51(APCLPRV)+1
.S A=$$AGE^AUPNPAT(DFN,APCLED)
.I A<19 S APCLDW6(APCLPRV)=APCLDW6(APCLPRV)+1
.I A>18,A<50 S APCLDW7(APCLPRV)=APCLDW7(APCLPRV)+1
.I A>49,A<65 S APCLDW8(APCLPRV)=APCLDW8(APCLPRV)+1
.I A>64 S APCLDW9(APCLPRV)=APCLDW9(APCLPRV)+1
.S APCLCOM=$$VAL^XBDIQ1(9000001,DFN,1118) I APCLCOM="" S APCLCOM="UNKNOWN"
.S ^(APCLCOM)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","COMM",APCLCOM)):^(APCLCOM)+1,1:1)
.S APCLTRIB=$$VAL^XBDIQ1(9000001,DFN,1108) I APCLTRIB="" S APCLTRIB="UNKNOWN"
.S ^(APCLTRIB)=$S($D(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","TRIBE",APCLTRIB)):^(APCLTRIB)+1,1:1)
Q
EM(V) ;
S Y=$P(^AUPNVSIT(V,0),U,17) I Y Q Y
S M=0,G="",Y="" F S M=$O(^AUPNVCPT("AD",V,M)) Q:M'=+M!(G]"") D
.S Z=""
.;S Y=$P(^AUPNVCPT(M,0),U),Z=$P(^ICPT(Y,0),U) ;cmi/anch/maw 9/12/2007 orig line
.S Y=$P(^AUPNVCPT(M,0),U),Z=$P($$CPT^ICPTCOD(Y),U,2) ;cmi/anch/maw 9/12/2007 csv
.I Z<99201!(Z>99499) Q
.S G=Y
.Q
Q G
APCLPP21 ; IHS/CMI/LAB - provider profile ;
+1 ;;2.0;IHS PCC SUITE;**7,10**;MAY 14, 2009;Build 88
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in EM
+4 ;
START ;
+1 SET APCLBT=$HOROLOG
SET (APCLDPPT,APCLDPPS,APCLDP2V)=0
+2 KILL APCLDPPT,APCLDPPS,APCLDP2V
+3 KILL APCLTCR,APCLTTEL,APCLANY,APCLAMB,APCLDW1,APCLDW2,APCLDW3,APCLDW4,APCLDW5,APCLDW6,APCLDW7,APCLDW8,APCLDW9,APCLDW10,APCLDW11,APCLDW12,APCLDW13,APCLDW14,APCLDW15
+4 ;
+5 SET Y=0
FOR
SET Y=$ORDER(APCLPROV(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+6 SET APCLDPPT(Y)=0
SET APCLDPPS(Y)=0
SET APCLDP2V(Y)=0
SET APCLTCR(Y)=0
SET APCLTTEL(Y)=0
SET APCLANY(Y)=0
SET APCLAMB(Y)=0
SET APCLDW1(Y)=0
SET APCLDW2(Y)=0
SET APCLDW3(Y)=0
SET APCLDW4(Y)=0
SET APCLDW5(Y)=0
SET APCLDW6(Y)=0
SET APCLDW7(Y)=0
SET APCLDW8(Y)=0
SET APCLDW9(Y)=0
SET APCLDW10(Y)=0
+7 SET APCLDW11(Y)=0
SET APCLDW12(Y)=0
SET APCLDW13(Y)=0
SET APCLDW14(Y)=0
SET APCLDW15(Y)=0
SET APCLTOTH(Y)=0
SET APCLDW51(Y)=0
End DoDot:1
+8 ;
+9 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
DO PROC
END ;
+1 KILL ^TMP($JOB)
+2 DO SET^APCLPP2
+3 SET APCLET=$HOROLOG
+4 KILL APCLCOM,APCLVREC
+5 QUIT
PROC ;
+1 SET APCLYDP=0
+2 IF '$DATA(^DPT(DFN,0))
QUIT
+3 ;merged
IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+4 IF $GET(APCLSEAT)
IF '$DATA(^DIBT(APCLSEAT,1,DFN))
QUIT
+5 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+6 SET X=$PIECE(^AUPNPAT(DFN,0),U,14)
IF X
IF $DATA(APCLPROV(X))
SET APCLDPPT(X)=$GET(APCLDPPT(X))+1
SET APCLYDP=X
+7 DO TALLYV
+8 QUIT
TALLYV ;
+1 KILL ^TMP($JOB,"A")
+2 SET A="^TMP($J,""A"","
SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCLBD)_"-"_$$FMTE^XLFDT(APCLED)
SET E=$$START1^APCLDF(B,A)
+3 IF '$DATA(^TMP($JOB,"A",1))
+4 KILL APCLANY,APCLAMB
SET Y=0
FOR
SET Y=$ORDER(APCLPROV(Y))
IF Y'=+Y
QUIT
SET APCLANY(Y)=0
SET APCLAMB(Y)=0
+5 SET APCLX=0
FOR
SET APCLX=$ORDER(^TMP($JOB,"A",APCLX))
IF APCLX'=+APCLX
QUIT
SET APCLV=$PIECE(^TMP($JOB,"A",APCLX),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(APCLV,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(APCLV,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(APCLV,0),U,11)
QUIT
+9 IF '$DATA(^AUPNVPRV("AD",APCLV))
QUIT
+10 SET (APCLPRIM,G,APCLZ)=0
+11 FOR
SET APCLZ=$ORDER(^AUPNVPRV("AD",APCLV,APCLZ))
IF APCLZ'=+APCLZ
QUIT
SET APCLPRIM=0
IF $DATA(^AUPNVPRV(APCLZ,0))
IF $DATA(APCLPROV($PIECE(^AUPNVPRV(APCLZ,0),U)))
SET APCLPRV=$PIECE(^AUPNVPRV(APCLZ,0),U)
IF $PIECE(^AUPNVPRV(APCLZ,0),U,4)="P"
SET APCLPRIM=1
Begin DoDot:2
+12 IF "EDX"'[$PIECE(^AUPNVSIT(APCLV,0),U,7)
SET APCLANY(APCLPRV)=APCLANY(APCLPRV)+1
+13 IF $PIECE(^AUPNVSIT(APCLV,0),U,7)="C"
SET APCLTCR(APCLPRV)=APCLTCR(APCLPRV)+1
+14 IF $PIECE(^AUPNVSIT(APCLV,0),U,7)="T"
SET APCLTTEL(APCLPRV)=APCLTTEL(APCLPRV)+1
+15 IF $PIECE(^AUPNVSIT(APCLV,0),U,7)="I"
IF $PIECE(^AUPNVSIT(APCLV,0),U,6)=APCLSUH
SET APCLDW14(APCLPRV)=APCLDW14(APCLPRV)+1
+16 IF $PIECE(^AUPNVSIT(APCLV,0),U,7)="I"
IF $PIECE(^AUPNVSIT(APCLV,0),U,6)'=APCLSUH
SET APCLDW15(APCLPRV)=APCLDW15(APCLPRV)+1
INP ;
+1 IF $PIECE(^AUPNVSIT(APCLV,0),U,7)="H"
IF APCLPRIM=1
SET APCLDW13(APCLPRV)=APCLDW13(APCLPRV)+1
Begin DoDot:3
+2 SET APCLEM=$$EM(APCLV)
IF APCLEM]""
SET ^(APCLEM)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","EM",APCLEM)):^(APCLEM)+1,1:1)
+3 SET P=0
FOR
SET P=$ORDER(^AUPNVPOV("AD",APCLV,P))
IF P'=+P
QUIT
SET I=$PIECE($GET(^AUPNVPOV(P,0)),U)
IF I
Begin DoDot:4
+4 IF APCLEXCL=1
IF $DATA(APCLDXT(I))
QUIT
+5 SET ^(I)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","INPTDX",I)):^(I)+1,1:1)
End DoDot:4
+6 SET APCLPOV=0
FOR
SET APCLPOV=$ORDER(^AUPNVPRC("AD",APCLV,APCLPOV))
IF APCLPOV=""
QUIT
Begin DoDot:4
+7 SET P=$PIECE($GET(^AUPNVPRC(APCLPOV,0)),U)
+8 IF 'P
QUIT
+9 SET ^(P)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","INPTSURGPROC",P)):^(P)+1,1:1)
End DoDot:4
End DoDot:3
AMB IF "AORS"[$PIECE(^AUPNVSIT(APCLV,0),U,7)
SET APCLAMB(APCLPRV)=APCLAMB(APCLPRV)+1
Begin DoDot:3
+1 ;total amb
SET APCLDW10(APCLPRV)=APCLDW10(APCLPRV)+1
+2 IF APCLPRIM
SET APCLDW11(APCLPRV)=APCLDW11(APCLPRV)+1
Begin DoDot:4
+3 SET APCLEM=$$EM(APCLV)
+4 IF APCLEM]""
SET ^(APCLEM)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","EM",APCLEM)):^(APCLEM)+1,1:1)
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVMED("AD",APCLV,X))
IF X'=+X
QUIT
IF $DATA(^AUPNVMED(X,0))
SET Y=$PIECE(^AUPNVMED(X,0),U)
SET Y=$PIECE(^PSDRUG(Y,0),U)
SET ^(Y)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","RX",Y)):^(Y)+1,1:1)
+6 SET APCLPOV=0
FOR
SET APCLPOV=$ORDER(^AUPNVPRC("AD",APCLV,APCLPOV))
IF APCLPOV=""
QUIT
Begin DoDot:5
+7 SET P=$PIECE($GET(^AUPNVPRC(APCLPOV,0)),U)
+8 IF 'P
QUIT
+9 SET ^(P)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SURGPROC",P)):^(P)+1,1:1)
End DoDot:5
End DoDot:4
+10 IF 'APCLPRIM
SET APCLDW12(APCLPRV)=APCLDW12(APCLPRV)+1
+11 SET APCLSC=$$VAL^XBDIQ1(9000010,APCLV,.07)
IF APCLSC=""
SET APCLSC="UNKNOWN"
+12 SET ^(APCLSC)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SC",APCLSC)):^(APCLSC)+1,1:1)
+13 SET APCLLOC=$$VAL^XBDIQ1(9000010,APCLV,.06)
IF APCLLOC=""
SET APCLLOC="UNKNOWN"
+14 SET ^(APCLLOC)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOC",APCLLOC)):^(APCLLOC)+1,1:1)
+15 SET P=0
FOR
SET P=$ORDER(^AUPNVPOV("AD",APCLV,P))
IF P'=+P
QUIT
SET I=$PIECE($GET(^AUPNVPOV(P,0)),U)
IF I
Begin DoDot:4
+16 IF APCLEXCL=1
IF $DATA(APCLDXT(I))
QUIT
+17 SET ^(I)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","OUTDX",I)):^(I)+1,1:1)
End DoDot:4
PATED ;
+1 SET APCLPOV=0
FOR
SET APCLPOV=$ORDER(^AUPNVPED("AD",APCLV,APCLPOV))
IF APCLPOV=""
QUIT
Begin DoDot:4
+2 IF '$DATA(^AUPNVPED(APCLPOV,0))
QUIT
+3 IF $PIECE(^AUPNVPED(APCLPOV,0),U,5)'=APCLPRV
QUIT
+4 SET P=$PIECE(^AUPNVPED(APCLPOV,0),U)
SET D=$PIECE(^AUTTEDT(P,0),U)
+5 SET ^(D)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","PATED",D)):^(D)+1,1:1)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+6 SET APCLPRV=0
FOR
SET APCLPRV=$ORDER(APCLPROV(APCLPRV))
IF APCLPRV'=+APCLPRV
QUIT
DO MORE
+7 QUIT
MORE ;
+1 IF APCLYDP=APCLPRV
IF APCLANY(APCLPRV)>0
SET APCLDPPS(APCLPRV)=APCLDPPS(APCLPRV)+1
+2 IF APCLAMB(APCLPRV)>1
IF $PIECE(^AUPNPAT(DFN,0),U,14)=""
SET APCLDP2V(APCLPRV)=APCLDP2V(APCLPRV)+1
+3 IF APCLANY(APCLPRV)>0
Begin DoDot:1
+4 SET APCLDW1(APCLPRV)=APCLDW1(APCLPRV)+1
+5 IF APCLYDP=APCLPRV
SET APCLDW2(APCLPRV)=APCLDW2(APCLPRV)+1
+6 IF APCLYDP'=APCLPRV
SET APCLDW3(APCLPRV)=APCLDW3(APCLPRV)+1
+7 IF $PIECE(^DPT(DFN,0),U,2)="M"
SET APCLDW4(APCLPRV)=APCLDW4(APCLPRV)+1
+8 IF $PIECE(^DPT(DFN,0),U,2)="F"
SET APCLDW5(APCLPRV)=APCLDW5(APCLPRV)+1
+9 IF $PIECE(^DPT(DFN,0),U,2)="U"
SET APCLDW51(APCLPRV)=APCLDW51(APCLPRV)+1
+10 SET A=$$AGE^AUPNPAT(DFN,APCLED)
+11 IF A<19
SET APCLDW6(APCLPRV)=APCLDW6(APCLPRV)+1
+12 IF A>18
IF A<50
SET APCLDW7(APCLPRV)=APCLDW7(APCLPRV)+1
+13 IF A>49
IF A<65
SET APCLDW8(APCLPRV)=APCLDW8(APCLPRV)+1
+14 IF A>64
SET APCLDW9(APCLPRV)=APCLDW9(APCLPRV)+1
+15 SET APCLCOM=$$VAL^XBDIQ1(9000001,DFN,1118)
IF APCLCOM=""
SET APCLCOM="UNKNOWN"
+16 SET ^(APCLCOM)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","COMM",APCLCOM)):^(APCLCOM)+1,1:1)
+17 SET APCLTRIB=$$VAL^XBDIQ1(9000001,DFN,1108)
IF APCLTRIB=""
SET APCLTRIB="UNKNOWN"
+18 SET ^(APCLTRIB)=$SELECT($DATA(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","TRIBE",APCLTRIB)):^(APCLTRIB)+1,1:1)
End DoDot:1
+19 QUIT
EM(V) ;
+1 SET Y=$PIECE(^AUPNVSIT(V,0),U,17)
IF Y
QUIT Y
+2 SET M=0
SET G=""
SET Y=""
FOR
SET M=$ORDER(^AUPNVCPT("AD",V,M))
IF M'=+M!(G]"")
QUIT
Begin DoDot:1
+3 SET Z=""
+4 ;S Y=$P(^AUPNVCPT(M,0),U),Z=$P(^ICPT(Y,0),U) ;cmi/anch/maw 9/12/2007 orig line
+5 ;cmi/anch/maw 9/12/2007 csv
SET Y=$PIECE(^AUPNVCPT(M,0),U)
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
+6 IF Z<99201!(Z>99499)
QUIT
+7 SET G=Y
+8 QUIT
End DoDot:1
+9 QUIT G
