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
Q
EXIT ;clean up and exit
D EN^XBVK("APCL")
D ^XBFMK
D KILL^AUPNPAT
Q
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
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
Q
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
Q
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))
Q
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
Q
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
Q
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
Q
;----------
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 ;----------
