APCLEL3 ; 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 all items from the elder care PCC form.",!
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."
ZIS ;call to XBDBQUE
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G DATE
S XBRP="PRINT^APCLEL3",XBRC="PROC^APCLEL3",XBRX="EXIT^APCLEL3",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("APCLEL3",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLEL3","ELDER CARE TALLY")
F X=.04:.01:.09 S ^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",X)="0^0^0^0"
F X=.11:.01:.16 S ^XTMP("APCLEL3",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
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 APCLDA=X F APCLX=.04:.01:.09 S V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX) S P=$S(V="":4,V="I":1,V="N":2,V="T":3,1:4),$P(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLX),U,P)=$P(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLX),U,P)+1
.S APCLDA=X F APCLX=.11:.01:.16 S V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX) S P=$S(V="":4,V="I":1,V="N":2,V="T":3,1:4),$P(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLX),U,P)=$P(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLX),U,P)+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
.S G(9999999-D)=X
.Q
I $O(G(0))="" Q ""
S X=0,X=$O(G(X)) Q G(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("APCLEL3",APCLJOB,APCLBTH)) D HEAD W !!,"NO DATA TO REPORT" G DONE
D TALLY
D DONE
Q
TALLY ;
D HEAD
W !!,"Total Number of Patients: ",APCLPTOT
S APCLA=0 F S APCLA=$O(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLA)) Q:APCLA=""!($D(APCLQ)) D
.I $Y>(IOSL-4) D HEAD Q:$D(APCLQ)
.W !!?2,$P(^DD(9000010.35,APCLA,0),U)
.S V=^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLA)
.S T=$P(V,U,1)+$P(V,U,2)+$P(V,U,3)+$P(V,U,4)
.W !?10,"INDEPENDENT",?30,$J($P(V,U,1),6),?45,$S($P(V,U,1):$J((($P(V,U,1)/T)*100),5,1),1:$J(0,5,1)),"%"
.W !?10,"NEEDS HELP",?30,$J($P(V,U,2),6),?45,$S($P(V,U,2):$J((($P(V,U,2)/T)*100),5,1),1:$J(0,5,1)),"%"
.W !?10,"TOTALLY DEPENDENT",?30,$J($P(V,U,3),6),?45,$S($P(V,U,3):$J((($P(V,U,3)/T)*100),5,1),1:$J(0,5,1)),"%"
.W !?10,"NOT DOCUMENTED",?30,$J($P(V,U,4),6),?45,$S($P(V,U,4):$J((($P(V,U,4)/T)*100),5,1),1:$J(0,5,1)),"%"
.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("APCLEL3",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("TALLY OF ELDER CARE DATA ITEMS",80),!
S X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80)
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")
;----------
APCLEL3 ; 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 all items from the elder care PCC form.",!
+5 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
ZIS ;call to XBDBQUE
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO DATE
+3 SET XBRP="PRINT^APCLEL3"
SET XBRC="PROC^APCLEL3"
SET XBRX="EXIT^APCLEL3"
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("APCLEL3",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLEL3","ELDER CARE TALLY")
+4 FOR X=.04:.01:.09
SET ^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",X)="0^0^0^0"
+5 FOR X=.11:.01:.16
SET ^XTMP("APCLEL3",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 DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+10 IF $$DOD^AUPNPAT(DFN)]""
QUIT
+11 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+12 ;has pt had functional assessment
+13 SET X=$$FA(DFN,APCLBD,APCLED)
+14 IF X=""
QUIT
+15 SET APCLPTOT=APCLPTOT+1
+16 ;tally each item
+17 SET APCLDA=X
FOR APCLX=.04:.01:.09
SET V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX)
SET P=$SELECT(V="":4,V="I":1,V="N":2,V="T":3,1:4)
SET $PIECE(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLX),U,P)=$PIECE(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLX),U,P)+1
+18 SET APCLDA=X
FOR APCLX=.11:.01:.16
SET V=$$VALI^XBDIQ1(9000010.35,APCLDA,APCLX)
SET P=$SELECT(V="":4,V="I":1,V="N":2,V="T":3,1:4)
SET $PIECE(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLX),U,P)=$PIECE(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLX),U,P)+1
End DoDot:1
+19 QUIT
+20 ;
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)
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("APCLEL3",APCLJOB,APCLBTH))
DO HEAD
WRITE !!,"NO DATA TO REPORT"
GOTO DONE
+5 DO TALLY
+6 DO DONE
+7 QUIT
TALLY ;
+1 DO HEAD
+2 WRITE !!,"Total Number of Patients: ",APCLPTOT
+3 SET APCLA=0
FOR
SET APCLA=$ORDER(^XTMP("APCLEL3",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,$PIECE(^DD(9000010.35,APCLA,0),U)
+6 SET V=^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLA)
+7 SET T=$PIECE(V,U,1)+$PIECE(V,U,2)+$PIECE(V,U,3)+$PIECE(V,U,4)
+8 WRITE !?10,"INDEPENDENT",?30,$JUSTIFY($PIECE(V,U,1),6),?45,$SELECT($PIECE(V,U,1):$JUSTIFY((($PIECE(V,U,1)/T)*100),5,1),1:$JUSTIFY(0,5,1)),"%"
+9 WRITE !?10,"NEEDS HELP",?30,$JUSTIFY($PIECE(V,U,2),6),?45,$SELECT($PIECE(V,U,2):$JUSTIFY((($PIECE(V,U,2)/T)*100),5,1),1:$JUSTIFY(0,5,1)),"%"
+10 WRITE !?10,"TOTALLY DEPENDENT",?30,$JUSTIFY($PIECE(V,U,3),6),?45,$SELECT($PIECE(V,U,3):$JUSTIFY((($PIECE(V,U,3)/T)*100),5,1),1:$JUSTIFY(0,5,1)),"%"
+11 WRITE !?10,"NOT DOCUMENTED",?30,$JUSTIFY($PIECE(V,U,4),6),?45,$SELECT($PIECE(V,U,4):$JUSTIFY((($PIECE(V,U,4)/T)*100),5,1),1:$JUSTIFY(0,5,1)),"%"
+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("APCLEL3",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("TALLY OF ELDER CARE DATA ITEMS",80),!
+6 SET X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED)
WRITE $$CTR(X,80)
+7 WRITE !,APCL80D
+8 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 ;----------
