Routine: APCLEL2

APCLEL2 ; IHS/CMI/LAB - patients with elder care assessment ;

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

START ;

INFORM ;

 W:$D(IOF) @IOF

 W !,$$CTR($$LOC)

 W !,$$CTR($$USR)

 W !!,"This report will tally by age, all patients who have had their change",!,"in functional status documented in the date range your specify."

 W !,"In addition, a list of patients who have had a decline in functional",!,"status will be listed.",!

 D EXIT

DATE ;get visit date range for functional assessment

 S (APCLBD,APCLED)=""

 K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Visit Date"

 D ^DIR K DIR G:Y<1 EXIT S APCLBD=Y

 K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Visit Date"

 D ^DIR K DIR G:Y<1 EXIT S APCLED=Y

 I APCLED<APCLBD D  G DATE

 . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."

AGE ;what age range of patients

 W !,"Please enter the age range of patients you are interested in."

W !

 S DIR(0)="F^1:7",DIR("A")="Enter an Age Range (e.g. 55-100,55-75)" D ^DIR K DIR

 I $D(DIRUT) G DATE

 I Y="" W !!,"No age range entered." G DATE

 I Y'?1.3N1"-"1.3N W !!,$C(7),$C(7),"Enter a numeric range in the format nnn-nnn. e.g. 0-5, 0-99, 5-20." G AGE

 I $P(Y,"-",2)>130 W !,"Enter an age range, maximum age 130",! G AGE

 S APCLAGET=Y

ZIS ;call to XBDBQUE

 S XBRP="PRINT^APCLEL2",XBRC="PROC^APCLEL2",XBRX="EXIT^APCLEL2",XBNS="APCL"

 D ^XBDBQUE

 D EXIT

EXIT ;clean up and exit

 D EN^XBVK("APCL")

 D ^XBFMK

 D KILL^AUPNPAT

PROC ;EP - called from XBDBQUE

 S APCLJOB=$J,APCLBTH=$H

 K ^XTMP("APCLEL2",APCLJOB,APCLBTH)

 D XTMP^APCLOSUT("APCLEL2","ELDER CARE TALLY")

 S I=$P(APCLAGET,"-"),J=$P(APCLAGET,"-",2)

 F X=I:1:J S ^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",X)="0^0^0^0"

 ;$o through patient file, check age of patient, community,

 ;# times seen, set demoninator counter by age,sex

 ;check for functional status in date range.  Set numerator cntr

 ;set list of patients for optional report

 S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D

 .Q:$$DOD^AUPNPAT(DFN)]""

 .Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))

 .S AGE=$$AGE^AUPNPAT(DFN,APCLBD)

 .I AGE<$P(APCLAGET,"-")!(AGE>$P(APCLAGET,"-",2)) Q

 .;has pt had functional assessment

 .S X=$$FA(DFN,APCLBD,APCLED)

 .I X="" Q

 .I $P(X,U)="D" S ^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIENT LIST",AGE,$P(^DPT(DFN,0),U,2),DFN)=$P(X,U,2)

 .S $P(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE),U)=$P($G(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE)),U)+1

 .I $P(X,U)="I" S $P(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE),U,2)=$P($G(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE)),U,2)+1

 .I $P(X,U)="S" S $P(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE),U,3)=$P($G(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE)),U,3)+1

 .I $P(X,U)="D" S $P(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE),U,4)=$P($G(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE)),U,4)+1

.Q

FA(P,B,E) ;

 I '$G(P) Q ""

 I '$D(^AUPNVELD("AC",P)) Q ""

 NEW X,Y,D,G

 K G S X=0,G="" F  S X=$O(^AUPNVELD("AC",P,X)) Q:X'=+X  D

 .S V=$P(^AUPNVELD(X,0),U,3),D=$P($P(^AUPNVSIT(V,0),U),".")

 .Q:D<B

 .Q:D>E

 .I $P(^AUPNVELD(X,0),U,17)]"" S G(9999999-D)=$P(^AUPNVELD(X,0),U,17)

.Q

 I $O(G(0))="" Q ""

 S X=0,X=$O(G(X)) Q G(X)_"^"_(9999999-X)

NUMV(P,E) ;

 I '$G(P) Q ""

 ;calcualte 3 yrs prior to E

 NEW B

 S B=$$FMADD^XLFDT(E,-(3*365))

 NEW X,J,APCL,Y

 S Y="APCL("

 S X=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(B)_"-"_$$FMTE^XLFDT(E) S J=$$START1^APCLDF(X,Y)

 S (X,Y)=0

 F  S X=$O(APCL(X)) Q:X'=+X  S Y=Y+1

 K APCL

Q Y

PRINT ;EP - called from xbdbque

 K APCLQ

 S APCL80D="-------------------------------------------------------------------------------"

 S APCLPG=0

 I '$D(^XTMP("APCLEL2",APCLJOB,APCLBTH)) S APCLTR="X" D HEAD W !!,"NO PATIENTS TO REPORT" G DONE

 D TALLY

 G:$D(APCLQ) DONE

 D LIST

 D DONE

TALLY ;

 S APCLTR="T",APCLTM=0,APCLTF=0

 D HEAD Q:$D(APCLQ)

 S APCLA=0 F  S APCLA=$O(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",APCLA)) Q:APCLA=""!($D(APCLQ))  D

 .I $Y>(IOSL-4) D HEAD Q:$D(APCLQ)

 .W !?2,APCLA

 .S APCLF=^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",APCLA),$P(APCLTF,U)=$P(APCLTF,U)+$P(APCLF,U),$P(APCLTF,U,2)=$P(APCLTF,U,2)+$P(APCLF,U,2),$P(APCLTF,U,3)=$P(APCLTF,U,3)+$P(APCLF,U,3),$P(APCLTF,U,4)=$P(APCLTF,U,4)+$P(APCLF,U,4)

 .I $P(APCLF,U)=0 F J=11,24,31,42,50,60,68 W ?J,"-"

 .I $P(APCLF,U)>0 W ?8,$J($P(APCLF,U),6),?21,$J($P(APCLF,U,2),6) S V=$J((($P(APCLF,U,2)/$P(APCLF,U))*100),5,1) W ?28,V

 .I $P(APCLF,U)>0 W ?39,$J($P(APCLF,U,3),6) S V=$J((($P(APCLF,U,3)/$P(APCLF,U))*100),5,1) W ?47,V

 .I $P(APCLF,U)>0 W ?57,$J($P(APCLF,U,4),6) S V=$J((($P(APCLF,U,4)/$P(APCLF,U))*100),5,1) W ?65,V

 Q:$D(APCLQ)

 I $Y>(IOSL-3) D HEAD Q:$D(APCLQ)

 W !!,"TOTAL"

 I $P(APCLTF,U)=0 F J=11,24,31,42,50,60,68 W ?J,"-"

 I $P(APCLTF,U)>0 W ?8,$J($P(APCLTF,U),6),?21,$J($P(APCLTF,U,2),6) S V=$J((($P(APCLTF,U,2)/$P(APCLTF,U))*100),5,1) W ?28,V

 I $P(APCLTF,U)>0 W ?39,$J($P(APCLTF,U,3),6) S V=$J((($P(APCLTF,U,3)/$P(APCLTF,U))*100),5,1) W ?47,V

 I $P(APCLTF,U)>0 W ?57,$J($P(APCLTF,U,4),6) S V=$J((($P(APCLTF,U,4)/$P(APCLTF,U))*100),5,1) W ?65,V

LIST ;

 S APCLTR="L"

 D HEAD Q:$D(APCLQ)

 S APCLA=0 F  S APCLA=$O(^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIENT LIST",APCLA)) Q:APCLA'=+APCLA!($D(APCLQ))  D

 .S APCLS="" F  S APCLS=$O(^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIENT LIST",APCLA,APCLS)) Q:APCLS=""!($D(APCLQ))  D

 ..S DFN=0 F  S DFN=$O(^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIENT LIST",APCLA,APCLS,DFN)) Q:DFN'=+DFN!($D(APCLQ))  D

 ...I $Y>(IOSL-3) D HEAD Q:$D(APCLQ)

 ...W !,$E($P(^DPT(DFN,0),U),1,25),?28,$$HRN^AUPNPAT(DFN,DUZ(2)),?37,$P(^DPT(DFN,0),U,2),?41,$$DOB^AUPNPAT(DFN,"E"),?59,$$AGE^AUPNPAT(DFN,APCLBD,"Y"),?65,$$FMTE^XLFDT(^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIENT LIST",APCLA,APCLS,DFN))

DONE ;

 I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report.  Press ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 W:$D(IOF) @IOF

 K ^XTMP("APCLEL2",APCLJOB,APCLBTH),APCLJOB,APCLBTH

HEAD I 'APCLPG G HEAD1

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQ="" Q

HEAD1 ;

 W:$D(IOF) @IOF S APCLPG=APCLPG+1

 W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"

 W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!

 W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!

 W $$CTR("PATIENTS WITH CHANGE IN FUNCTIONAL ASSESSMENT DOCUMENTED",80),!

 S X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80)

 I APCLTR="L" S X="Listing of Patient with a documented DECLINE in Functional Satus" W !,$$CTR(X,80)

 W !,APCL80D

 I APCLTR="T" W !,?9,"# OF",?24,"IMPROVED",?44,"SAME",?60,"DECLINED",!,"AGE",?8,"PATIENTS",?24,"#",?31,"%",?42,"#",?50,"%",?60,"#",?68,"%",!,?22,"------------",?40,"-------------",?58,"-------------"

 I APCLTR="L" W !?64,"LAST FUNCTIONAL",!,"PATIENT NAME",?28,"HRN",?36,"SEX",?41,"DOB",?59,"AGE",?64,"ASSESSMENT",!,APCL80D

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

EOP ;EP - End of page.

 Q:$E(IOST)'="C"

 Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 S DIR(0)="E" D ^DIR

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 ;----------

APCLEL2   ; IHS/CMI/LAB - patients with elder care assessment ;

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

 +2       ;

 +3       ;

START     ;

INFORM    ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !,$$CTR($$LOC)

 +3        WRITE !,$$CTR($$USR)

 +4        WRITE !!,"This report will tally by age, all patients who have had their change",!,"in functional status documented in the date range your specify."

 +5        WRITE !,"In addition, a list of patients who have had a decline in functional",!,"status will be listed.",!

 +6        DO EXIT

DATE      ;get visit date range for functional assessment

 +1        SET (APCLBD,APCLED)=""

 +2        KILL DIR

           WRITE !

           SET DIR(0)="DO^::EXP"

           SET DIR("A")="Enter Beginning Visit Date"

 +3        DO ^DIR

           KILL DIR

           IF Y<1

               GOTO EXIT

           SET APCLBD=Y

 +4        KILL DIR

           SET DIR(0)="DO^::EXP"

           SET DIR("A")="Enter Ending Visit Date"

 +5        DO ^DIR

           KILL DIR

           IF Y<1

               GOTO EXIT

           SET APCLED=Y

 +6       ;

 +7        IF APCLED<APCLBD

               Begin DoDot:1

 +8                WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."

               End DoDot:1

               GOTO DATE

AGE       ;what age range of patients

 +1        WRITE !,"Please enter the age range of patients you are interested in."

 +2        WRITE !

 +3        SET DIR(0)="F^1:7"

           SET DIR("A")="Enter an Age Range (e.g. 55-100,55-75)"

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO DATE

 +5        IF Y=""

               WRITE !!,"No age range entered."

               GOTO DATE

 +6        IF Y'?1.3N1"-"1.3N

               WRITE !!,$CHAR(7),$CHAR(7),"Enter a numeric range in the format nnn-nnn. e.g. 0-5, 0-99, 5-20."

               GOTO AGE

 +7        IF $PIECE(Y,"-",2)>130

               WRITE !,"Enter an age range, maximum age 130",!

               GOTO AGE

 +8        SET APCLAGET=Y

ZIS       ;call to XBDBQUE

 +1        SET XBRP="PRINT^APCLEL2"

           SET XBRC="PROC^APCLEL2"

           SET XBRX="EXIT^APCLEL2"

           SET XBNS="APCL"

 +2        DO ^XBDBQUE

 +3        DO EXIT

 +4        QUIT

EXIT      ;clean up and exit

 +1        DO EN^XBVK("APCL")

 +2        DO ^XBFMK

 +3        DO KILL^AUPNPAT

 +4        QUIT

PROC      ;EP - called from XBDBQUE

 +1        SET APCLJOB=$JOB

           SET APCLBTH=$HOROLOG

 +2        KILL ^XTMP("APCLEL2",APCLJOB,APCLBTH)

 +3        DO XTMP^APCLOSUT("APCLEL2","ELDER CARE TALLY")

 +4        SET I=$PIECE(APCLAGET,"-")

           SET J=$PIECE(APCLAGET,"-",2)

 +5        FOR X=I:1:J

               SET ^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",X)="0^0^0^0"

 +6       ;$o through patient file, check age of patient, community,

 +7       ;# times seen, set demoninator counter by age,sex

 +8       ;check for functional status in date range.  Set numerator cntr

 +9       ;set list of patients for optional report

 +10       SET DFN=0

FOR

               SET DFN=$ORDER(^AUPNPAT(DFN))

               IF DFN'=+DFN

                   QUIT

               Begin DoDot:1

 +11               IF $$DOD^AUPNPAT(DFN)]""

                       QUIT

 +12               IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))

                       QUIT

 +13               SET AGE=$$AGE^AUPNPAT(DFN,APCLBD)

 +14               IF AGE<$PIECE(APCLAGET,"-")!(AGE>$PIECE(APCLAGET,"-",2))

                       QUIT

 +15      ;has pt had functional assessment

 +16               SET X=$$FA(DFN,APCLBD,APCLED)

 +17               IF X=""

                       QUIT

 +18               IF $PIECE(X,U)="D"

                       SET ^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIENT LIST",AGE,$PIECE(^DPT(DFN,0),U,2),DFN)=$PIECE(X,U,2)

 +19               SET $PIECE(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE),U)=$PIECE($GET(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE)),U)+1

 +20               IF $PIECE(X,U)="I"

                       SET $PIECE(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE),U,2)=$PIECE($GET(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE)),U,2)+1

 +21               IF $PIECE(X,U)="S"

                       SET $PIECE(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE),U,3)=$PIECE($GET(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE)),U,3)+1

 +22               IF $PIECE(X,U)="D"

                       SET $PIECE(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE),U,4)=$PIECE($GET(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",AGE)),U,4)+1

 +23               QUIT

               End DoDot:1

 +24       QUIT

 +25      ;

FA(P,B,E) ;

 +1        IF '$GET(P)

               QUIT ""

 +2        IF '$DATA(^AUPNVELD("AC",P))

               QUIT ""

 +3        NEW X,Y,D,G

 +4        KILL G

           SET X=0

           SET G=""

FOR

               SET X=$ORDER(^AUPNVELD("AC",P,X))

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +5                SET V=$PIECE(^AUPNVELD(X,0),U,3)

                   SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")

 +6                IF D<B

                       QUIT

 +7                IF D>E

                       QUIT

 +8                IF $PIECE(^AUPNVELD(X,0),U,17)]""

                       SET G(9999999-D)=$PIECE(^AUPNVELD(X,0),U,17)

 +9                QUIT

               End DoDot:1

 +10       IF $ORDER(G(0))=""

               QUIT ""

 +11       SET X=0

           SET X=$ORDER(G(X))

           QUIT G(X)_"^"_(9999999-X)

NUMV(P,E) ;

 +1        IF '$GET(P)

               QUIT ""

 +2       ;calcualte 3 yrs prior to E

 +3        NEW B

 +4        SET B=$$FMADD^XLFDT(E,-(3*365))

 +5        NEW X,J,APCL,Y

 +6        SET Y="APCL("

 +7        SET X=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(B)_"-"_$$FMTE^XLFDT(E)

           SET J=$$START1^APCLDF(X,Y)

 +8        SET (X,Y)=0

 +9        FOR

               SET X=$ORDER(APCL(X))

               IF X'=+X

                   QUIT

               SET Y=Y+1

 +10       KILL APCL

 +11       QUIT Y

 +12      ;

PRINT     ;EP - called from xbdbque

 +1        KILL APCLQ

 +2        SET APCL80D="-------------------------------------------------------------------------------"

 +3        SET APCLPG=0

 +4        IF '$DATA(^XTMP("APCLEL2",APCLJOB,APCLBTH))

               SET APCLTR="X"

               DO HEAD

               WRITE !!,"NO PATIENTS TO REPORT"

               GOTO DONE

 +5        DO TALLY

 +6        IF $DATA(APCLQ)

               GOTO DONE

 +7        DO LIST

 +8        DO DONE

 +9        QUIT

TALLY     ;

 +1        SET APCLTR="T"

           SET APCLTM=0

           SET APCLTF=0

 +2        DO HEAD

           IF $DATA(APCLQ)

               QUIT

 +3        SET APCLA=0

FOR

               SET APCLA=$ORDER(^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",APCLA))

               IF APCLA=""!($DATA(APCLQ))

                   QUIT

               Begin DoDot:1

 +4                IF $Y>(IOSL-4)

                       DO HEAD

                       IF $DATA(APCLQ)

                           QUIT

 +5                WRITE !?2,APCLA

 +6                SET APCLF=^XTMP("APCLEL2",APCLJOB,APCLBTH,"TALLY",APCLA)

                   SET $PIECE(APCLTF,U)=$PIECE(APCLTF,U)+$PIECE(APCLF,U)

                   SET $PIECE(APCLTF,U,2)=$PIECE(APCLTF,U,2)+$PIECE(APCLF,U,2)

                   SET $PIECE(APCLTF,U,3)=$PIECE(APCLTF,U,3)+$PIECE(APCLF,U,3)

                   SET $PIECE(APCLTF,U,4)=$PIECE(APCLTF,U,4)+$PIECE(APCLF,U,4)

 +7                IF $PIECE(APCLF,U)=0

                       FOR J=11,24,31,42,50,60,68

                           WRITE ?J,"-"

 +8                IF $PIECE(APCLF,U)>0

                       WRITE ?8,$JUSTIFY($PIECE(APCLF,U),6),?21,$JUSTIFY($PIECE(APCLF,U,2),6)

                       SET V=$JUSTIFY((($PIECE(APCLF,U,2)/$PIECE(APCLF,U))*100),5,1)

                       WRITE ?28,V

 +9                IF $PIECE(APCLF,U)>0

                       WRITE ?39,$JUSTIFY($PIECE(APCLF,U,3),6)

                       SET V=$JUSTIFY((($PIECE(APCLF,U,3)/$PIECE(APCLF,U))*100),5,1)

                       WRITE ?47,V

 +10               IF $PIECE(APCLF,U)>0

                       WRITE ?57,$JUSTIFY($PIECE(APCLF,U,4),6)

                       SET V=$JUSTIFY((($PIECE(APCLF,U,4)/$PIECE(APCLF,U))*100),5,1)

                       WRITE ?65,V

               End DoDot:1

 +11       IF $DATA(APCLQ)

               QUIT

 +12       IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(APCLQ)

                   QUIT

 +13       WRITE !!,"TOTAL"

 +14       IF $PIECE(APCLTF,U)=0

               FOR J=11,24,31,42,50,60,68

                   WRITE ?J,"-"

 +15       IF $PIECE(APCLTF,U)>0

               WRITE ?8,$JUSTIFY($PIECE(APCLTF,U),6),?21,$JUSTIFY($PIECE(APCLTF,U,2),6)

               SET V=$JUSTIFY((($PIECE(APCLTF,U,2)/$PIECE(APCLTF,U))*100),5,1)

               WRITE ?28,V

 +16       IF $PIECE(APCLTF,U)>0

               WRITE ?39,$JUSTIFY($PIECE(APCLTF,U,3),6)

               SET V=$JUSTIFY((($PIECE(APCLTF,U,3)/$PIECE(APCLTF,U))*100),5,1)

               WRITE ?47,V

 +17       IF $PIECE(APCLTF,U)>0

               WRITE ?57,$JUSTIFY($PIECE(APCLTF,U,4),6)

               SET V=$JUSTIFY((($PIECE(APCLTF,U,4)/$PIECE(APCLTF,U))*100),5,1)

               WRITE ?65,V

 +18       QUIT

LIST      ;

 +1        SET APCLTR="L"

 +2        DO HEAD

           IF $DATA(APCLQ)

               QUIT

 +3        SET APCLA=0

FOR

               SET APCLA=$ORDER(^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIENT LIST",APCLA))

               IF APCLA'=+APCLA!($DATA(APCLQ))

                   QUIT

               Begin DoDot:1

 +4                SET APCLS=""

FOR

                       SET APCLS=$ORDER(^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIENT LIST",APCLA,APCLS))

                       IF APCLS=""!($DATA(APCLQ))

                           QUIT

                       Begin DoDot:2

 +5                        SET DFN=0

FOR

                               SET DFN=$ORDER(^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIENT LIST",APCLA,APCLS,DFN))

                               IF DFN'=+DFN!($DATA(APCLQ))

                                   QUIT

                               Begin DoDot:3

 +6                                IF $Y>(IOSL-3)

                                       DO HEAD

                                       IF $DATA(APCLQ)

                                           QUIT

 +7                                WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,25),?28,$$HRN^AUPNPAT(DFN,DUZ(2)),?37,$PIECE(^DPT(DFN,0),U,2),?41,$$DOB^AUPNPAT(DFN,"E"),?59,$$AGE^AUPNPAT(DFN,APCLBD,"Y"),?65,$$FMTE^XLFDT(^XTMP("APCLEL2",APCLJOB,APCLBTH,"PATIEN

T LIST",APCLA,APCLS,DFN))

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +8        QUIT

DONE      ;

 +1        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   SET DIR(0)="EO"

                   SET DIR("A")="End of report.  Press ENTER"

                   DO ^DIR

                   KILL DIR

                   IF $DATA(DUOUT)

                       SET DIRUT=1

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        KILL ^XTMP("APCLEL2",APCLJOB,APCLBTH),APCLJOB,APCLBTH

 +4        QUIT

HEAD       IF 'APCLPG

               GOTO HEAD1

 +1        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET APCLQ=""

                       QUIT

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET APCLPG=APCLPG+1

 +2        WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"

 +3        WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!

 +4        WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!

 +5        WRITE $$CTR("PATIENTS WITH CHANGE IN FUNCTIONAL ASSESSMENT DOCUMENTED",80),!

 +6        SET X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED)

           WRITE $$CTR(X,80)

 +7        IF APCLTR="L"

               SET X="Listing of Patient with a documented DECLINE in Functional Satus"

               WRITE !,$$CTR(X,80)

 +8        WRITE !,APCL80D

 +9        IF APCLTR="T"

               WRITE !,?9,"# OF",?24,"IMPROVED",?44,"SAME",?60,"DECLINED",!,"AGE",?8,"PATIENTS",?24,"#",?31,"%",?42,"#",?50,"%",?60,"#",?68,"%",!,?22,"------------",?40,"-------------",?58,"-------------"

 +10       IF APCLTR="L"

               WRITE !?64,"LAST FUNCTIONAL",!,"PATIENT NAME",?28,"HRN",?36,"SEX",?41,"DOB",?59,"AGE",?64,"ASSESSMENT",!,APCL80D

 +11       QUIT

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

EOP       ;EP - End of page.

 +1        IF $EXTRACT(IOST)'="C"

               QUIT

 +2        IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))

               QUIT

 +3        NEW DIR

 +4        KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 +5        SET DIR(0)="E"

           DO ^DIR

 +6        QUIT

 +7       ;----------

USR()     ;EP - Return name of current user from ^VA(200.

 +1        QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 +2       ;----------

LOC()     ;EP - Return location name from file 4 based on DUZ(2).

 +1        QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 +2       ;----------

APCLEL2.m