Routine: APCLEL4

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

EXIT ;clean up and exit

 D EN^XBVK("APCL")

 D ^XBFMK

 D KILL^AUPNPAT

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

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

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

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

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

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")

 ;----------

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       ;----------

APCLEL4.m