- 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
