APCLEL1 ; IHS/CMI/LAB - patients with elder care assessment ; 02 Sep 2010 7:05 AM
;;2.0;IHS PCC SUITE;**5,10**;MAY 14, 2009;Build 88
;
;
START ;
INFORM ;
W:$D(IOF) @IOF
W !,$$CTR($$LOC)
W !,$$CTR($$USR)
W !!,"This report will tally by age/sex, all patients who have had a functional",!,"assessment in a date range you specify. You will also specity what age"
W !,"range of patients you are interested in. In order to determine the demoninator",!,"or population of patients to review, you will be asked if you want "
W "patients who live a particular community or set of communities",!,"and to specify the minimum number of times the must have been seen"
W !,"in the 3 years prior to the end of your date range in order to be included ",!,"in the report.",!
W !,"You will be given the opportunity to get a tally of patients only, ",!,"or to get a tally and a list of the patients.",!!
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
CMMNTS ;
K APCLCOMM
S DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)",DIR("A")="Review patients who live in",DIR("B")="O" K DA D ^DIR K DIR
G:$D(DIRUT) AGE
I Y="A" W !!,"Patients from all communities will be included in the report.",! G NV
I Y="O" D G:'$D(APCLCOMM) CMMNTS G NV
.K APCLCOMM
.S DIC="^AUTTCOM(",DIC(0)="AEMQ",DIC("A")="Which COMMUNITY: " D ^DIC K DIC
.Q:Y=-1
.S APCLCOMM($P(^AUTTCOM(+Y,0),U))=""
K APCLCOMM S X="COMMUNITY",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" S APCLERR=1 Q
D PEP^AMQQGTX0(+Y,"APCLCOMM(")
I '$D(APCLCOMM) G CMMNTS
I $D(APCLCOMM("*")) K APCLCOMM G CMMNTS
;
NV ;
W !!,"In order to determine 'active' patients please indicate the minimum number of"
W !,"times the patient must have been seen in the 3 years prior to ",$$FMTE^XLFDT(APCLED),!,"in order to be considered active and be included in this report.",!
S DIR(0)="N^1:999:0",DIR("A")="How many times must the patient have been seen",DIR("B")="3" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G CMMNTS
S APCLNV=Y
;
RPT ;
S APCLRPT=""
S DIR(0)="S^T:Tally of patients by age/sex;L:List of Patients;B:Both a Tally and a List",DIR("A")="Would you like to produce",DIR("B")="T" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G NV
S APCLRPT=Y
;
ZIS ;call to XBDBQUE
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G RPT
S XBRP="PRINT^APCLEL1",XBRC="PROC^APCLEL1",XBRX="EXIT^APCLEL1",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("APCLEL1",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLEL1","ELDER CARE TALLY")
S I=$P(APCLAGET,"-"),J=$P(APCLAGET,"-",2)
F X=I:1:J S ^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",X,"F")=0,^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",X,"M")=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
.;check community
.I $D(APCLCOMM) S C=$P($G(^AUPNPAT(DFN,11)),U,18) Q:C="" I '$D(APCLCOMM(C)) Q
.;check number of times seen
.I $$NUMV(DFN,APCLED)<APCLNV Q
.;has pt had functional assessment
.S X=$$FA(DFN,APCLBD,APCLED)
.S ^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",AGE,$P(^DPT(DFN,0),U,2),DFN)=X
.S S=$P(^DPT(DFN,0),U,2)
.I S="U" S S="M"
.S $P(^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",AGE,S),U)=$P($G(^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",AGE,$P(^DPT(DFN,0),U,2))),U)+1
.S $P(^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",AGE,S),U,2)=$P($G(^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",AGE,$P(^DPT(DFN,0),U,2))),U,2)+($S(X]"":1,1:0))
.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
.S G(9999999-D)=X
.Q
I $O(G(0))="" Q ""
Q 9999999-$O(G(0))
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("APCLEL1",APCLJOB,APCLBTH)) S APCLTR="X" D HEAD W !!,"NO PATIENTS TO REPORT" G DONE
I APCLRPT="B"!(APCLRPT="T") D TALLY
G:$D(APCLQ) DONE
I APCLRPT="B"!(APCLRPT="L") 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("APCLEL1",APCLJOB,APCLBTH,"TALLY",APCLA)) Q:APCLA=""!($D(APCLQ)) D
.I $Y>(IOSL-4) D HEAD Q:$D(APCLQ)
.W !?2,APCLA
.S APCLF=^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",APCLA,"F"),$P(APCLTF,U)=$P(APCLTF,U)+$P(APCLF,U),$P(APCLTF,U,2)=$P(APCLTF,U,2)+$P(APCLF,U,2)
.S APCLM=^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",APCLA,"M"),$P(APCLTM,U)=$P(APCLTM,U)+$P(APCLM,U),$P(APCLTM,U,2)=$P(APCLTM,U,2)+$P(APCLM,U,2)
.I $P(APCLF,U)=0 W ?20,"-",?27,"-",?33,"-"
.I $P(APCLF,U)>0 W ?15,$J($P(APCLF,U,2),6),?22,$J($P(APCLF,U),6) S V=$J((($P(APCLF,U,2)/$P(APCLF,U))*100),5,1) W ?29,V
.I $P(APCLM,U)=0 W ?40,"-",?47,"-",?53,"-"
.I $P(APCLM,U)>0 W ?35,$J($P(APCLM,U,2),6),?42,$J($P(APCLM,U),6) S V=$J((($P(APCLM,U,2)/$P(APCLM,U))*100),5,1) W ?49,V
.S T=$P(APCLM,U)+$P(APCLF,U),T1=$P(APCLM,U,2)+$P(APCLF,U,2)
.I T=0 W ?60,"-",?67,"-",?73,"-"
.I T>0 W ?55,$J(T1,6),?62,$J(T,6) S V=$J(((T1/T)*100),5,1) W ?69,V
Q:$D(APCLQ)
I $Y>(IOSL-3) D HEAD Q:$D(APCLQ)
W !!,"TOTAL"
I $P(APCLTF,U)=0 W ?20,"-",?27,"-",?33,"-"
I $P(APCLTF,U)>0 W ?15,$J($P(APCLTF,U,2),6),?22,$J($P(APCLTF,U),6) S V=$J((($P(APCLTF,U,2)/$P(APCLTF,U))*100),5,1) W ?29,V
I $P(APCLTM,U)=0 W ?40,"-",?47,"-",?53,"-"
I $P(APCLTM,U)>0 W ?35,$J($P(APCLTM,U,2),6),?42,$J($P(APCLTM,U),6) S V=$J((($P(APCLTM,U,2)/$P(APCLTM,U))*100),5,1) W ?49,V
S T=$P(APCLTM,U)+$P(APCLTF,U),T1=$P(APCLTM,U,2)+$P(APCLTF,U,2)
I T=0 W ?60,"-",?67,"-",?73,"-"
I T>0 W ?55,$J(T1,6),?62,$J(T,6) S V=$J(((T1/T)*100),5,1) W ?69,V
Q
LIST ;
S APCLTR="L"
D HEAD Q:$D(APCLQ)
S APCLA=0 F S APCLA=$O(^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",APCLA)) Q:APCLA'=+APCLA!($D(APCLQ)) D
.S APCLS="" F S APCLS=$O(^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",APCLA,APCLS)) Q:APCLS=""!($D(APCLQ)) D
..S DFN=0 F S DFN=$O(^XTMP("APCLEL1",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("APCLEL1",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("APCLEL1",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 FUNCTIONAL ASSESSMENT DOCUMENTED",80),!
S X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80)
I '$D(APCLCOMM) S X="All Communities" W !,$$CTR(X)
I $D(APCLCOMM) S X="Selected Communities" W !,$$CTR(X)
W !,APCL80D
I APCLTR="T" W !,?24,"FEMALES",?42,"MALES/UNKNOWN",?65,"TOTAL",!,?20,"#",?27,"N",?32,"%",?40,"#",?47,"N",?52,"%",?60,"#",?66,"N",?72,"%",!,?17,"------------------" D
.W ?37,"------------------",?57,"------------------"
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")
;----------
APCLEL1 ; IHS/CMI/LAB - patients with elder care assessment ; 02 Sep 2010 7:05 AM
+1 ;;2.0;IHS PCC SUITE;**5,10**;MAY 14, 2009;Build 88
+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/sex, all patients who have had a functional",!,"assessment in a date range you specify. You will also specity what age"
+5 WRITE !,"range of patients you are interested in. In order to determine the demoninator",!,"or population of patients to review, you will be asked if you want "
+6 WRITE "patients who live a particular community or set of communities",!,"and to specify the minimum number of times the must have been seen"
+7 WRITE !,"in the 3 years prior to the end of your date range in order to be included ",!,"in the report.",!
+8 WRITE !,"You will be given the opportunity to get a tally of patients only, ",!,"or to get a tally and a list of the patients.",!!
+9 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
CMMNTS ;
+1 KILL APCLCOMM
+2 SET DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)"
SET DIR("A")="Review patients who live in"
SET DIR("B")="O"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO AGE
+4 IF Y="A"
WRITE !!,"Patients from all communities will be included in the report.",!
GOTO NV
+5 IF Y="O"
Begin DoDot:1
+6 KILL APCLCOMM
+7 SET DIC="^AUTTCOM("
SET DIC(0)="AEMQ"
SET DIC("A")="Which COMMUNITY: "
DO ^DIC
KILL DIC
+8 IF Y=-1
QUIT
+9 SET APCLCOMM($PIECE(^AUTTCOM(+Y,0),U))=""
End DoDot:1
IF '$DATA(APCLCOMM)
GOTO CMMNTS
GOTO NV
+10 KILL APCLCOMM
SET X="COMMUNITY"
SET DIC="^AMQQ(5,"
SET DIC(0)="FM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC,DA
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
SET APCLERR=1
QUIT
+11 DO PEP^AMQQGTX0(+Y,"APCLCOMM(")
+12 IF '$DATA(APCLCOMM)
GOTO CMMNTS
+13 IF $DATA(APCLCOMM("*"))
KILL APCLCOMM
GOTO CMMNTS
+14 ;
NV ;
+1 WRITE !!,"In order to determine 'active' patients please indicate the minimum number of"
+2 WRITE !,"times the patient must have been seen in the 3 years prior to ",$$FMTE^XLFDT(APCLED),!,"in order to be considered active and be included in this report.",!
+3 SET DIR(0)="N^1:999:0"
SET DIR("A")="How many times must the patient have been seen"
SET DIR("B")="3"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO CMMNTS
+5 SET APCLNV=Y
+6 ;
RPT ;
+1 SET APCLRPT=""
+2 SET DIR(0)="S^T:Tally of patients by age/sex;L:List of Patients;B:Both a Tally and a List"
SET DIR("A")="Would you like to produce"
SET DIR("B")="T"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO NV
+4 SET APCLRPT=Y
+5 ;
ZIS ;call to XBDBQUE
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO RPT
+3 SET XBRP="PRINT^APCLEL1"
SET XBRC="PROC^APCLEL1"
SET XBRX="EXIT^APCLEL1"
SET XBNS="APCL"
+4 DO ^XBDBQUE
+5 DO EXIT
+6 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("APCLEL1",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLEL1","ELDER CARE TALLY")
+4 SET I=$PIECE(APCLAGET,"-")
SET J=$PIECE(APCLAGET,"-",2)
+5 FOR X=I:1:J
SET ^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",X,"F")=0
SET ^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",X,"M")=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 ;check community
+16 IF $DATA(APCLCOMM)
SET C=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
IF C=""
QUIT
IF '$DATA(APCLCOMM(C))
QUIT
+17 ;check number of times seen
+18 IF $$NUMV(DFN,APCLED)<APCLNV
QUIT
+19 ;has pt had functional assessment
+20 SET X=$$FA(DFN,APCLBD,APCLED)
+21 SET ^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",AGE,$PIECE(^DPT(DFN,0),U,2),DFN)=X
+22 SET S=$PIECE(^DPT(DFN,0),U,2)
+23 IF S="U"
SET S="M"
+24 SET $PIECE(^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",AGE,S),U)=$PIECE($GET(^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",AGE,$PIECE(^DPT(DFN,0),U,2))),U)+1
+25 SET $PIECE(^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",AGE,S),U,2)=$PIECE($GET(^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",AGE,$PIECE(^DPT(DFN,0),U,2))),U,2)+($SELECT(X]"":1,1:0))
+26 QUIT
End DoDot:1
+27 QUIT
+28 ;
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 SET G(9999999-D)=X
+9 QUIT
End DoDot:1
+10 IF $ORDER(G(0))=""
QUIT ""
+11 QUIT 9999999-$ORDER(G(0))
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("APCLEL1",APCLJOB,APCLBTH))
SET APCLTR="X"
DO HEAD
WRITE !!,"NO PATIENTS TO REPORT"
GOTO DONE
+5 IF APCLRPT="B"!(APCLRPT="T")
DO TALLY
+6 IF $DATA(APCLQ)
GOTO DONE
+7 IF APCLRPT="B"!(APCLRPT="L")
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("APCLEL1",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("APCLEL1",APCLJOB,APCLBTH,"TALLY",APCLA,"F")
SET $PIECE(APCLTF,U)=$PIECE(APCLTF,U)+$PIECE(APCLF,U)
SET $PIECE(APCLTF,U,2)=$PIECE(APCLTF,U,2)+$PIECE(APCLF,U,2)
+7 SET APCLM=^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",APCLA,"M")
SET $PIECE(APCLTM,U)=$PIECE(APCLTM,U)+$PIECE(APCLM,U)
SET $PIECE(APCLTM,U,2)=$PIECE(APCLTM,U,2)+$PIECE(APCLM,U,2)
+8 IF $PIECE(APCLF,U)=0
WRITE ?20,"-",?27,"-",?33,"-"
+9 IF $PIECE(APCLF,U)>0
WRITE ?15,$JUSTIFY($PIECE(APCLF,U,2),6),?22,$JUSTIFY($PIECE(APCLF,U),6)
SET V=$JUSTIFY((($PIECE(APCLF,U,2)/$PIECE(APCLF,U))*100),5,1)
WRITE ?29,V
+10 IF $PIECE(APCLM,U)=0
WRITE ?40,"-",?47,"-",?53,"-"
+11 IF $PIECE(APCLM,U)>0
WRITE ?35,$JUSTIFY($PIECE(APCLM,U,2),6),?42,$JUSTIFY($PIECE(APCLM,U),6)
SET V=$JUSTIFY((($PIECE(APCLM,U,2)/$PIECE(APCLM,U))*100),5,1)
WRITE ?49,V
+12 SET T=$PIECE(APCLM,U)+$PIECE(APCLF,U)
SET T1=$PIECE(APCLM,U,2)+$PIECE(APCLF,U,2)
+13 IF T=0
WRITE ?60,"-",?67,"-",?73,"-"
+14 IF T>0
WRITE ?55,$JUSTIFY(T1,6),?62,$JUSTIFY(T,6)
SET V=$JUSTIFY(((T1/T)*100),5,1)
WRITE ?69,V
End DoDot:1
+15 IF $DATA(APCLQ)
QUIT
+16 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(APCLQ)
QUIT
+17 WRITE !!,"TOTAL"
+18 IF $PIECE(APCLTF,U)=0
WRITE ?20,"-",?27,"-",?33,"-"
+19 IF $PIECE(APCLTF,U)>0
WRITE ?15,$JUSTIFY($PIECE(APCLTF,U,2),6),?22,$JUSTIFY($PIECE(APCLTF,U),6)
SET V=$JUSTIFY((($PIECE(APCLTF,U,2)/$PIECE(APCLTF,U))*100),5,1)
WRITE ?29,V
+20 IF $PIECE(APCLTM,U)=0
WRITE ?40,"-",?47,"-",?53,"-"
+21 IF $PIECE(APCLTM,U)>0
WRITE ?35,$JUSTIFY($PIECE(APCLTM,U,2),6),?42,$JUSTIFY($PIECE(APCLTM,U),6)
SET V=$JUSTIFY((($PIECE(APCLTM,U,2)/$PIECE(APCLTM,U))*100),5,1)
WRITE ?49,V
+22 SET T=$PIECE(APCLTM,U)+$PIECE(APCLTF,U)
SET T1=$PIECE(APCLTM,U,2)+$PIECE(APCLTF,U,2)
+23 IF T=0
WRITE ?60,"-",?67,"-",?73,"-"
+24 IF T>0
WRITE ?55,$JUSTIFY(T1,6),?62,$JUSTIFY(T,6)
SET V=$JUSTIFY(((T1/T)*100),5,1)
WRITE ?69,V
+25 QUIT
LIST ;
+1 SET APCLTR="L"
+2 DO HEAD
IF $DATA(APCLQ)
QUIT
+3 SET APCLA=0
FOR
SET APCLA=$ORDER(^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",APCLA))
IF APCLA'=+APCLA!($DATA(APCLQ))
QUIT
Begin DoDot:1
+4 SET APCLS=""
FOR
SET APCLS=$ORDER(^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",APCLA,APCLS))
IF APCLS=""!($DATA(APCLQ))
QUIT
Begin DoDot:2
+5 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("APCLEL1",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("APCLEL1",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("APCLEL1",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 FUNCTIONAL ASSESSMENT DOCUMENTED",80),!
+6 SET X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED)
WRITE $$CTR(X,80)
+7 IF '$DATA(APCLCOMM)
SET X="All Communities"
WRITE !,$$CTR(X)
+8 IF $DATA(APCLCOMM)
SET X="Selected Communities"
WRITE !,$$CTR(X)
+9 WRITE !,APCL80D
+10 IF APCLTR="T"
WRITE !,?24,"FEMALES",?42,"MALES/UNKNOWN",?65,"TOTAL",!,?20,"#",?27,"N",?32,"%",?40,"#",?47,"N",?52,"%",?60,"#",?66,"N",?72,"%",!,?17,"------------------"
Begin DoDot:1
+11 WRITE ?37,"------------------",?57,"------------------"
End DoDot:1
+12 IF APCLTR="L"
WRITE !?64,"LAST FUNCTIONAL",!,"PATIENT NAME",?28,"HRN",?36,"SEX",?41,"DOB",?59,"AGE",?64,"ASSESSMENT",!,APCL80D
+13 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 ;----------
