APCLEL4 ; 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 the number of patients who have had",!,"2 or more items in the ADL and 2 or more items in the IADL groups",!,"documented as NEEDS HELP or TOTALLY DEPENDENT.",!
W !,"All patients who have had a functional assessment in the year prior the as of",!,"date entered will be reviewed.",!
W !,"A list of the patients will also be listed.",!
D EXIT
DATE ;get visit date range for functional assessment
S APCLED=""
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter As of Visit Date"
D ^DIR K DIR G:Y<1 EXIT S APCLED=Y
S APCLBD=$$FMADD^XLFDT(APCLED,-365)
;
ZIS ;call to XBDBQUE
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G DATE
S XBRP="PRINT^APCLEL4",XBRC="PROC^APCLEL4",XBRX="EXIT^APCLEL4",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,APCLPTOT=0
K ^XTMP("APCLEL4",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLEL4","ELDER CARE TALLY")
S APCLADL=0,APCLIADL=0
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.Q:$$DOD^AUPNPAT(DFN)]""
.Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
.;has pt had functional assessment
.S X=$$FA(DFN,APCLBD,APCLED)
.I X="" Q
.S APCLPTOT=APCLPTOT+1
.;tally each item
.S G=0,APCLDA=X F APCLX=.04:.01:.09 S V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX) I V="T"!(V="N") S G=G+1
.S H=0,APCLDA=X F APCLX=.11:.01:.16 S V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX) I V="T"!(V="N") S H=H+1
.I G>1,H>1 S APCLADL=APCLADL+1,^XTMP("APCLEL4",APCLJOB,APCLBTH,"TALLY",DFN)=X
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 ""
S X=0,X=$O(G(X)) Q G(X)
PRINT ;EP - called from xbdbque
K APCLQ
S APCL80D="-------------------------------------------------------------------------------",APCLTR="T"
S APCLPG=0
I '$D(^XTMP("APCLEL4",APCLJOB,APCLBTH)) D HEAD W !!,"NO DATA TO REPORT" G DONE
D TALLY
D DONE
Q
TALLY ;
S APCLTR="L"
D HEAD
W !!,"Total Number of Patients w/Functional Assessment Documented: ",?70,$J(APCLPTOT,6)
W !!,"Total Number of Patients w/2 or more in ADL and IADL documented",!,"as NEEDS HELP or TOTALLY DEPENDENT",?70,$J(APCLADL,6),!!
D HEAD
S DFN=0 F S DFN=$O(^XTMP("APCLEL4",APCLJOB,APCLBTH,"TALLY",DFN)) Q:DFN=""!($D(APCLQ)) D
.I $Y>(IOSL-4) D HEAD Q:$D(APCLQ)
.S APCLIEN=^XTMP("APCLEL4",APCLJOB,APCLBTH,"TALLY",DFN)
.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($P(^AUPNVSIT($P(^AUPNVELD(APCLIEN,0),U,3),0),U),"1D"),!
.S G=0,APCLDA=APCLIEN F APCLX=.04:.01:.09 S V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX) W $P(^DD(9000010.35,APCLX,0),U),"-",V," "
.W ! S H=0,APCLDA=APCLIEN F APCLX=.11:.01:.16 S V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX) W $E($P(^DD(9000010.35,APCLX,0),U),1,12),"-",V," "
.Q
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("APCLEL4",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("ELDER PATIENTS WITH 2 OR MORE ITEMS",80),!
W $$CTR("documented as NEEDS HELP or TOTALLY DEPENDENT",80),!
S X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80)
I APCLTR="L" W !?64,"LAST FUNCTIONAL",!,"PATIENT NAME",?28,"HRN",?36,"SEX",?41,"DOB",?59,"AGE",?64,"ASSESSMENT"
W !,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")
;----------
APCLEL4 ; 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 the number of patients who have had",!,"2 or more items in the ADL and 2 or more items in the IADL groups",!,"documented as NEEDS HELP or TOTALLY DEPENDENT.",!
+5 WRITE !,"All patients who have had a functional assessment in the year prior the as of",!,"date entered will be reviewed.",!
+6 WRITE !,"A list of the patients will also be listed.",!
+7 DO EXIT
DATE ;get visit date range for functional assessment
+1 SET APCLED=""
+2 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter As of Visit Date"
+3 DO ^DIR
KILL DIR
IF Y<1
GOTO EXIT
SET APCLED=Y
+4 SET APCLBD=$$FMADD^XLFDT(APCLED,-365)
+5 ;
ZIS ;call to XBDBQUE
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO DATE
+3 SET XBRP="PRINT^APCLEL4"
SET XBRC="PROC^APCLEL4"
SET XBRX="EXIT^APCLEL4"
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
SET APCLPTOT=0
+2 KILL ^XTMP("APCLEL4",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLEL4","ELDER CARE TALLY")
+4 SET APCLADL=0
SET APCLIADL=0
+5 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+6 IF $$DOD^AUPNPAT(DFN)]""
QUIT
+7 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+8 ;has pt had functional assessment
+9 SET X=$$FA(DFN,APCLBD,APCLED)
+10 IF X=""
QUIT
+11 SET APCLPTOT=APCLPTOT+1
+12 ;tally each item
+13 SET G=0
SET APCLDA=X
FOR APCLX=.04:.01:.09
SET V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX)
IF V="T"!(V="N")
SET G=G+1
+14 SET H=0
SET APCLDA=X
FOR APCLX=.11:.01:.16
SET V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX)
IF V="T"!(V="N")
SET H=H+1
+15 IF G>1
IF H>1
SET APCLADL=APCLADL+1
SET ^XTMP("APCLEL4",APCLJOB,APCLBTH,"TALLY",DFN)=X
End DoDot:1
+16 QUIT
+17 ;
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 SET X=0
SET X=$ORDER(G(X))
QUIT G(X)
PRINT ;EP - called from xbdbque
+1 KILL APCLQ
+2 SET APCL80D="-------------------------------------------------------------------------------"
SET APCLTR="T"
+3 SET APCLPG=0
+4 IF '$DATA(^XTMP("APCLEL4",APCLJOB,APCLBTH))
DO HEAD
WRITE !!,"NO DATA TO REPORT"
GOTO DONE
+5 DO TALLY
+6 DO DONE
+7 QUIT
TALLY ;
+1 SET APCLTR="L"
+2 DO HEAD
+3 WRITE !!,"Total Number of Patients w/Functional Assessment Documented: ",?70,$JUSTIFY(APCLPTOT,6)
+4 WRITE !!,"Total Number of Patients w/2 or more in ADL and IADL documented",!,"as NEEDS HELP or TOTALLY DEPENDENT",?70,$JUSTIFY(APCLADL,6),!!
+5 DO HEAD
+6 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("APCLEL4",APCLJOB,APCLBTH,"TALLY",DFN))
IF DFN=""!($DATA(APCLQ))
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQ)
QUIT
+8 SET APCLIEN=^XTMP("APCLEL4",APCLJOB,APCLBTH,"TALLY",DFN)
+9 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($PIECE(^AUPNVSIT($PIECE(^AUPNVELD(APCLIEN,0),U,3),0),U)
,"1D"),!
+10 SET G=0
SET APCLDA=APCLIEN
FOR APCLX=.04:.01:.09
SET V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX)
WRITE $PIECE(^DD(9000010.35,APCLX,0),U),"-",V," "
+11 WRITE !
SET H=0
SET APCLDA=APCLIEN
FOR APCLX=.11:.01:.16
SET V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX)
WRITE $EXTRACT($PIECE(^DD(9000010.35,APCLX,0),U),1,12),"-",V," "
+12 QUIT
End DoDot:1
+13 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("APCLEL4",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("ELDER PATIENTS WITH 2 OR MORE ITEMS",80),!
+6 WRITE $$CTR("documented as NEEDS HELP or TOTALLY DEPENDENT",80),!
+7 SET X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED)
WRITE $$CTR(X,80)
+8 IF APCLTR="L"
WRITE !?64,"LAST FUNCTIONAL",!,"PATIENT NAME",?28,"HRN",?36,"SEX",?41,"DOB",?59,"AGE",?64,"ASSESSMENT"
+9 WRITE !,APCL80D
+10 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 ;----------
