APCLCP5.m

APCLCP5 ; IHS/CMI/LAB - DISC tally activity time ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

START ; 

 I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q

 S APCLSITE=DUZ(2)

 I APCLSORV="APCLVLOC" S APCLNSP="APCLCP5",APCLSORT="LOCATION OF ENCOUNTER"

 I APCLSORV="APCLCODE" S APCLNSP="APCLCP5",APCLSORT="PRIMARY DX"

 D INFORM

 ;

GETGROUP ;

 W ! S DIC="^APCLACTG(",DIC("A")="Enter the Provider Discipline Group you wish to report on: ",DIC(0)="AEMQ" D ^DIC

 I Y=-1 W !,"Bye ... " G XIT

 S APCLACTG=+Y

 W !!,"You have selected the ",$P(Y,U,2)," discipline group.",!

 S DIC="^APCLACTG(",DA=+Y D EN^DIQ K DIC,DA

GETDATES ;

BD ;get beginning date

 W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Visit Date for Search" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G GETGROUP

 S APCLBD=Y

ED ;get ending date

 W ! S DIR(0)="DA^"_APCLBD_":DT:EP",DIR("A")="Enter ending Visit Date for Search:  " S Y=APCLBD D DD^%DT S Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S APCLED=Y

 S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X

 ;

LOC ;get location

 K APCLLOC

 S DIR(0)="S^O:One Location;T:Taxonomy of or Selected Set of Locations;A:All Locations"

 S DIR("A")="Include visits from which set of locations",DIR("B")="A" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) BD

 I Y="A" K APCLLOC G CLINIC

 I Y="O" D O^APCLCP1 G:$D(APCLQ) LOC

 I Y="T" D T^APCLCP1 G:$D(APCLQ) LOC

CLINIC ;

 K APCLCLN

 S DIR(0)="S^O:One Clinic;T:Taxonomy of or Selected Set of Clinics;A:All Clinics"

 S DIR("A")="Include visits from which set of clinics",DIR("B")="A" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) LOC

 I Y="A" K APCLCLN G ZIS

 I Y="O" D OC^APCLCP1 G:$D(APCLQ) CLINIC

 I Y="T" D TC^APCLCP1 G:$D(APCLQ) CLINIC

 ;

ZIS ;

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G CLINIC

 S XBRP="^APCLCP5P",XBRC="PROCESS^APCLCP5",XBRX="XIT^APCLCP5",XBNS="APCL"

 D ^XBDBQUE

 D XIT

 Q

 ;

ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q

XIT ;

 K APCL80S,APCLBDD,APCLBT,APCLDT,APCLED,APCLEDD,APCLLENG,APCLLOC,APCLPG,APCLQUIT,APCL1,APCL2,APCLAP,APCLDISC,APCLODAT,APCLSD,APCLSKIP,APCLVACT,APCLVDFN,APCLVLOC,APCLVREC,APCLVTM,APCLVTT,APCLX,APCLY,APCLPRIM,APCLSITE,APCLBD

 K APCLACTG,APCLPIEC,APCLGLOB,APCLRRTN,APCLJOB

 K X,Z,X1,X2,%,Y,DIRUT,POP,ZTSK,T,S,M,TS,H,DIR,DUOUT,DTOUT,DUOUT,DLOUT,APCLNSP,APCLSORT,APCLZ,APCLSORV,APCLVAL,APCLSUB

 Q

 ;

INFORM ;

 W:$D(IOF) @IOF

 W !,"Time and Services Report by Provider a Group of Provider Disciplines",!,"that you select.",!

 W !,"This report displays by ",APCLSORT,", the number of patient",!,"CHART REVIEWS and the total activity and travel time for each provider",!,"with a discipline in the provider discipline group that you select."

 W !

 Q

 ;

PROCESS ;EP - called from xbdbque

 S APCLJOB=$J,APCLBT=$H

 I $P(^APCLACTG(APCLACTG,0),U,2)]"",$P(^(0),U,3)]"",$P(^(0),U,4)]"" D  I 1

 .S APCLRRTN=$S($P($P(^APCLACTG(APCLACTG,0),U,2),"~",2)]"":$P($P(^APCLACTG(APCLACTG,0),U,2),"~")_"^"_$P($P(^APCLACTG(APCLACTG,0),U,2),"~",2),1:$P(^APCLACTG(APCLACTG,0),U,2)),APCLPIEC=$P(^(0),U,4),APCLGLOB="^"_$P(^(0),U,3)_"("

 .S X=APCLRRTN X ^%ZOSF("TEST") I '$T S APCLRRTN="",APCLGLOB="^ICD9(",APCLPIEC=3 Q

 E  S APCLGLOB="^ICD9(",APCLRRTN="",APCLPIEC=3

 I APCLRRTN]"" S APCLRRTN="^"_APCLRRTN

V ; Run by visit date

 K ^XTMP(APCLNSP,APCLJOB,APCLBT)

 D XTMP^APCLOSUT(APCLNSP,"PCC ACTIVITY REPORT")

 S APCLODAT=$O(^AUPNVSIT("B",APCLSD)) G:APCLODAT="" END

 S APCLODAT=APCLSD_".9999" F  S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED)  D V1

END ;

 D EOJ

 S APCLET=$H

 Q

V1 ;

 S APCLVDFN=0 F  S APCLVDFN=$O(^AUPNVSIT("B",APCLODAT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN  I $D(^AUPNVSIT(APCLVDFN,0)) S APCLVREC=^(0) I $P(APCLVREC,U,9),'$P(APCLVREC,U,11),$D(^AUPNVPRV("AD",APCLVDFN)),$D(^AUPNVPOV("AD",APCLVDFN)) D PROC,EOJ

 Q

PROC ;

 K APCLSKIP

 Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))

 Q:$P(APCLVREC,U,7)'="C"

 I $D(APCLLOC) Q:$P(APCLVREC,U,6)=""  I '$D(APCLLOC($P(APCLVREC,U,6))) Q

 I $D(APCLCLN) Q:$P(APCLVREC,U,8)=""  I '$D(APCLCLN($P(APCLVREC,U,8))) Q

 S (APCL1,APCL2)=0 F  S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2=""  I $P(^AUPNVPRV(APCL2,0),U,4)="P" S APCL1=APCL1+1,APCLAP=$P(^(0),U)

 Q:APCL1=0

 Q:APCL1>1

 S APCLVLOC=$P(APCLVREC,U,6)

 D PROC2

 Q

EOJ K APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLPRIM,@APCLSORV,APCLDISC,APCLVLOC,APCLVTM,APCLVTT,APCLCODE,APCLIPTR

 Q

 ;

 ;

PROC2 ;

 S APCLZ=0 F  S APCLZ=$O(^AUPNVPRV("AD",APCLVDFN,APCLZ)) Q:APCLZ'=+APCLZ  D

 . S APCLAP=$P(^AUPNVPRV(APCLZ,0),U)

 . I $P(^DD(9000010.06,.01,0),U,2)[200 S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) G PROC21

 . S APCLY=$P(^VA(200,APCLAP,0),U,4)

 . Q:APCLY=""

 . Q:'$D(^DIC(7,APCLY,9999999))

 . S APCLDISC=$P(^DIC(7,APCLY,9999999),U)

PROC21 . I '$D(^APCLACTG(APCLACTG,11,"AC",APCLDISC)) Q

 . I APCLSORV="APCLCODE" D GETCODE Q:'APCLCODE

 . S ^("TOTAL")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"TOTAL")):^("TOTAL")+1,1:1)

 . I $P(^AUPNVPRV(APCLZ,0),U,4)="P" S ^("PRIM")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"PRIM")):^("PRIM")+1,1:1)

 . I $P(^AUPNVPRV(APCLZ,0),U,4)'="P" S ^("SEC")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"SEC")):^("SEC")+1,1:1)

 . I '$D(^AUPNVTM("AD",APCLVDFN)) S ^("NOACT")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,"NOACT")):^("NOACT")+1,1:1) Q

 . S APCLVTM=$O(^AUPNVTM("AD",APCLVDFN,"")),APCLVACT=$P(^AUPNVTM(APCLVTM,0),U),APCLVTT=$P(^AUPNVTM(APCLVTM,0),U,4)

 . S ^("ACT")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"ACT")):^("ACT")+APCLVACT,1:APCLVACT)

 . I APCLVTT S ^("TT")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"TT")):^("TT")+APCLVTT,1:APCLVTT)

 . Q

 Q

GETCODE ;

 D GETPPOV

 S APCLIPTR=$P(^AUPNVPOV(APCL1,0),U)

 I $G(APCLRRTN)]"" D @APCLRRTN Q

 S APCLCODE=APCLIPTR

 Q

GETPPOV ;

 I $P(APCLVREC,U,7)'="H" S APCL1=$O(^AUPNVPOV("AD",APCLVDFN,"")) Q

 S (APCL1,APCL2)=0 F  S APCL2=$O(^AUPNVPOV("AD",APCLVDFN,APCL2)) Q:APCL2'=+APCL2!(APCL1)  I $P(^AUPNVPOV(APCL2,0),U,12)="P" S APCL1=APCL2

 Q

 ;

APCLCP5   ; IHS/CMI/LAB - DISC tally activity time ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

START     ; 

 +1        IF '$GET(DUZ(2))

               WRITE $CHAR(7),$CHAR(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!!

               QUIT 

 +2        SET APCLSITE=DUZ(2)

 +3        IF APCLSORV="APCLVLOC"

               SET APCLNSP="APCLCP5"

               SET APCLSORT="LOCATION OF ENCOUNTER"

 +4        IF APCLSORV="APCLCODE"

               SET APCLNSP="APCLCP5"

               SET APCLSORT="PRIMARY DX"

 +5        DO INFORM

 +6       ;

GETGROUP  ;

 +1        WRITE !

           SET DIC="^APCLACTG("

           SET DIC("A")="Enter the Provider Discipline Group you wish to report on: "

           SET DIC(0)="AEMQ"

           DO ^DIC

 +2        IF Y=-1

               WRITE !,"Bye ... "

               GOTO XIT

 +3        SET APCLACTG=+Y

 +4        WRITE !!,"You have selected the ",$PIECE(Y,U,2)," discipline group.",!

 +5        SET DIC="^APCLACTG("

           SET DA=+Y

           DO EN^DIQ

           KILL DIC,DA

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !

           SET DIR(0)="D^:DT:EP"

           SET DIR("A")="Enter beginning Visit Date for Search"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO GETGROUP

 +3        SET APCLBD=Y

ED        ;get ending date

 +1        WRITE !

           SET DIR(0)="DA^"_APCLBD_":DT:EP"

           SET DIR("A")="Enter ending Visit Date for Search:  "

           SET Y=APCLBD

           DO DD^%DT

           SET Y=""

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET APCLED=Y

 +4        SET X1=APCLBD

           SET X2=-1

           DO C^%DTC

           SET APCLSD=X

 +5       ;

LOC       ;get location

 +1        KILL APCLLOC

 +2        SET DIR(0)="S^O:One Location;T:Taxonomy of or Selected Set of Locations;A:All Locations"

 +3        SET DIR("A")="Include visits from which set of locations"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO BD

 +5        IF Y="A"

               KILL APCLLOC

               GOTO CLINIC

 +6        IF Y="O"

               DO O^APCLCP1

               IF $DATA(APCLQ)

                   GOTO LOC

 +7        IF Y="T"

               DO T^APCLCP1

               IF $DATA(APCLQ)

                   GOTO LOC

CLINIC    ;

 +1        KILL APCLCLN

 +2        SET DIR(0)="S^O:One Clinic;T:Taxonomy of or Selected Set of Clinics;A:All Clinics"

 +3        SET DIR("A")="Include visits from which set of clinics"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO LOC

 +5        IF Y="A"

               KILL APCLCLN

               GOTO ZIS

 +6        IF Y="O"

               DO OC^APCLCP1

               IF $DATA(APCLQ)

                   GOTO CLINIC

 +7        IF Y="T"

               DO TC^APCLCP1

               IF $DATA(APCLQ)

                   GOTO CLINIC

 +8       ;

ZIS       ;

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO CLINIC

 +3        SET XBRP="^APCLCP5P"

           SET XBRC="PROCESS^APCLCP5"

           SET XBRX="XIT^APCLCP5"

           SET XBNS="APCL"

 +4        DO ^XBDBQUE

 +5        DO XIT

 +6        QUIT 

 +7       ;

ERR        WRITE $CHAR(7),$CHAR(7),!,"Must be a valid date and be Today or earlier. Time not allowed!"

           QUIT 

XIT       ;

 +1        KILL APCL80S,APCLBDD,APCLBT,APCLDT,APCLED,APCLEDD,APCLLENG,APCLLOC,APCLPG,APCLQUIT,APCL1,APCL2,APCLAP,APCLDISC,APCLODAT,APCLSD,APCLSKIP,APCLVACT,APCLVDFN,APCLVLOC,APCLVREC,APCLVTM,APCLVTT,APCLX,APCLY,APCLPRIM,APCLSITE,APCLBD

 +2        KILL APCLACTG,APCLPIEC,APCLGLOB,APCLRRTN,APCLJOB

 +3        KILL X,Z,X1,X2,%,Y,DIRUT,POP,ZTSK,T,S,M,TS,H,DIR,DUOUT,DTOUT,DUOUT,DLOUT,APCLNSP,APCLSORT,APCLZ,APCLSORV,APCLVAL,APCLSUB

 +4        QUIT 

 +5       ;

INFORM    ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !,"Time and Services Report by Provider a Group of Provider Disciplines",!,"that you select.",!

 +3        WRITE !,"This report displays by ",APCLSORT,", the number of patient",!,"CHART REVIEWS and the total activity and travel time for each provider",!,"with a discipline in the provider discipline group that you select."

 +4        WRITE !

 +5        QUIT 

 +6       ;

PROCESS   ;EP - called from xbdbque

 +1        SET APCLJOB=$JOB

           SET APCLBT=$HOROLOG

 +2        IF $PIECE(^APCLACTG(APCLACTG,0),U,2)]""

               IF $PIECE(^(0),U,3)]""

                   IF $PIECE(^(0),U,4)]""

                       Begin DoDot:1

 +3                        SET APCLRRTN=$SELECT($PIECE($PIECE(^APCLACTG(APCLACTG,0),U,2),"~",2)]"":$PIECE($PIECE(^APCLACTG(APCLACTG,0),U,2),"~")_"^"_$PIECE($PIECE(^APCLACTG(APCLACTG,0),U,2),"~",2),1:$PIECE(^APCLACTG(APCLACTG,0),U,2))

                           SET APCLPIEC=$PIECE(^(0),U,4)

                           SET APCLGLOB="^"_$PIECE(^(0),U,3)_"("

 +4                        SET X=APCLRRTN

                           XECUTE ^%ZOSF("TEST")

                           IF '$TEST

                               SET APCLRRTN=""

                               SET APCLGLOB="^ICD9("

                               SET APCLPIEC=3

                               QUIT 

                       End DoDot:1

                       IF 1

 +5       IF '$TEST

               SET APCLGLOB="^ICD9("

               SET APCLRRTN=""

               SET APCLPIEC=3

 +6        IF APCLRRTN]""

               SET APCLRRTN="^"_APCLRRTN

V         ; Run by visit date

 +1        KILL ^XTMP(APCLNSP,APCLJOB,APCLBT)

 +2        DO XTMP^APCLOSUT(APCLNSP,"PCC ACTIVITY REPORT")

 +3        SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLSD))

           IF APCLODAT=""

               GOTO END

 +4        SET APCLODAT=APCLSD_".9999"

           FOR 

               SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))

               IF APCLODAT=""!((APCLODAT\1)>APCLED)

                   QUIT 

               DO V1

END       ;

 +1        DO EOJ

 +2        SET APCLET=$HOROLOG

 +3        QUIT 

V1        ;

 +1        SET APCLVDFN=0

           FOR 

               SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVDFN))

               IF APCLVDFN'=+APCLVDFN

                   QUIT 

               IF $DATA(^AUPNVSIT(APCLVDFN,0))

                   SET APCLVREC=^(0)

                   IF $PIECE(APCLVREC,U,9)

                       IF '$PIECE(APCLVREC,U,11)

                           IF $DATA(^AUPNVPRV("AD",APCLVDFN))

                               IF $DATA(^AUPNVPOV("AD",APCLVDFN))

                                   DO PROC

                                   DO EOJ

 +2        QUIT 

PROC      ;

 +1        KILL APCLSKIP

 +2        IF $$DEMO^APCLUTL($PIECE(APCLVREC,U,5),$GET(APCLDEMO))

               QUIT 

 +3        IF $PIECE(APCLVREC,U,7)'="C"

               QUIT 

 +4        IF $DATA(APCLLOC)

               IF $PIECE(APCLVREC,U,6)=""

                   QUIT 

               IF '$DATA(APCLLOC($PIECE(APCLVREC,U,6)))

                   QUIT 

 +5        IF $DATA(APCLCLN)

               IF $PIECE(APCLVREC,U,8)=""

                   QUIT 

               IF '$DATA(APCLCLN($PIECE(APCLVREC,U,8)))

                   QUIT 

 +6        SET (APCL1,APCL2)=0

           FOR 

               SET APCL2=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCL2))

               IF APCL2=""

                   QUIT 

               IF $PIECE(^AUPNVPRV(APCL2,0),U,4)="P"

                   SET APCL1=APCL1+1

                   SET APCLAP=$PIECE(^(0),U)

 +7        IF APCL1=0

               QUIT 

 +8        IF APCL1>1

               QUIT 

 +9        SET APCLVLOC=$PIECE(APCLVREC,U,6)

 +10       DO PROC2

 +11       QUIT 

EOJ        KILL APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLPRIM,@APCLSORV,APCLDISC,APCLVLOC,APCLVTM,APCLVTT,APCLCODE,APCLIPTR

 +1        QUIT 

 +2       ;

 +3       ;

PROC2     ;

 +1        SET APCLZ=0

           FOR 

               SET APCLZ=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCLZ))

               IF APCLZ'=+APCLZ

                   QUIT 

               Begin DoDot:1

 +2                SET APCLAP=$PIECE(^AUPNVPRV(APCLZ,0),U)

 +3                IF $PIECE(^DD(9000010.06,.01,0),U,2)[200

                       SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)

                       GOTO PROC21

 +4                SET APCLY=$PIECE(^VA(200,APCLAP,0),U,4)

 +5                IF APCLY=""

                       QUIT 

 +6                IF '$DATA(^DIC(7,APCLY,9999999))

                       QUIT 

 +7                SET APCLDISC=$PIECE(^DIC(7,APCLY,9999999),U)

PROC21             IF '$DATA(^APCLACTG(APCLACTG,11,"AC",APCLDISC))

                       QUIT 

 +1                IF APCLSORV="APCLCODE"

                       DO GETCODE

                       IF 'APCLCODE

                           QUIT 

 +2                SET ^("TOTAL")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"TOTAL")):^("TOTAL")+1,1:1)

 +3                IF $PIECE(^AUPNVPRV(APCLZ,0),U,4)="P"

                       SET ^("PRIM")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"PRIM")):^("PRIM")+1,1:1)

 +4                IF $PIECE(^AUPNVPRV(APCLZ,0),U,4)'="P"

                       SET ^("SEC")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"SEC")):^("SEC")+1,1:1)

 +5                IF '$DATA(^AUPNVTM("AD",APCLVDFN))

                       SET ^("NOACT")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,"NOACT")):^("NOACT")+1,1:1)

                       QUIT 

 +6                SET APCLVTM=$ORDER(^AUPNVTM("AD",APCLVDFN,""))

                   SET APCLVACT=$PIECE(^AUPNVTM(APCLVTM,0),U)

                   SET APCLVTT=$PIECE(^AUPNVTM(APCLVTM,0),U,4)

 +7                SET ^("ACT")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"ACT")):^("ACT")+APCLVACT,1:APCLVACT)

 +8                IF APCLVTT

                       SET ^("TT")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"TT")):^("TT")+APCLVTT,1:APCLVTT)

 +9                QUIT 

               End DoDot:1

 +10       QUIT 

GETCODE   ;

 +1        DO GETPPOV

 +2        SET APCLIPTR=$PIECE(^AUPNVPOV(APCL1,0),U)

 +3        IF $GET(APCLRRTN)]""

               DO @APCLRRTN

               QUIT 

 +4        SET APCLCODE=APCLIPTR

 +5        QUIT 

GETPPOV   ;

 +1        IF $PIECE(APCLVREC,U,7)'="H"

               SET APCL1=$ORDER(^AUPNVPOV("AD",APCLVDFN,""))

               QUIT 

 +2        SET (APCL1,APCL2)=0

           FOR 

               SET APCL2=$ORDER(^AUPNVPOV("AD",APCLVDFN,APCL2))

               IF APCL2'=+APCL2!(APCL1)

                   QUIT 

               IF $PIECE(^AUPNVPOV(APCL2,0),U,12)="P"

                   SET APCL1=APCL2

 +3        QUIT 

 +4       ;