Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLEL3

APCLEL3.m

Go to the documentation of this file. 
  1. APCLEL3 ; IHS/CMI/LAB - patients with elder care assessment ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1.  ;
  1. START ;
  1. INFORM ;
  1.  W:$D(IOF) @IOF
  1.  W !,$$CTR($$LOC)
  1.  W !,$$CTR($$USR)
  1.  W !!,"This report will tally all items from the elder care PCC form.",!
  1.  D EXIT
  1. DATE ;get visit date range for functional assessment
  1.  S (APCLBD,APCLED)=""
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Visit Date"
  1.  D ^DIR K DIR G:Y<1 EXIT S APCLBD=Y
  1.  K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Visit Date"
  1.  D ^DIR K DIR G:Y<1 EXIT S APCLED=Y
  1.  ;
  1.  I APCLED<APCLBD D  G DATE
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1. ZIS ;call to XBDBQUE
  1. DEMO ;
  1.  D DEMOCHK^APCLUTL(.APCLDEMO)
  1.  I APCLDEMO=-1 G DATE
  1.  S XBRP="PRINT^APCLEL3",XBRC="PROC^APCLEL3",XBRX="EXIT^APCLEL3",XBNS="APCL"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1. EXIT ;clean up and exit
  1.  D EN^XBVK("APCL")
  1.  D ^XBFMK
  1.  D KILL^AUPNPAT
  1.  Q
  1. PROC ;EP - called from XBDBQUE
  1.  S APCLJOB=$J,APCLBTH=$H,APCLPTOT=0
  1.  K ^XTMP("APCLEL3",APCLJOB,APCLBTH)
  1.  D XTMP^APCLOSUT("APCLEL3","ELDER CARE TALLY")
  1.  F X=.04:.01:.09 S ^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",X)="0^0^0^0"
  1.  F X=.11:.01:.16 S ^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",X)="0^0^0^0"
  1.  ;$o through patient file, check age of patient, community, 
  1.  ;# times seen, set demoninator counter by age,sex
  1.  ;check for functional status in date range.  Set numerator cntr
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D
  1.  .Q:$$DOD^AUPNPAT(DFN)]""
  1.  .Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
  1.  .;has pt had functional assessment
  1.  .S X=$$FA(DFN,APCLBD,APCLED)
  1.  .I X="" Q
  1.  .S APCLPTOT=APCLPTOT+1
  1.  .;tally each item
  1.  .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
  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
  1.  Q
  1.  ;
  1. FA(P,B,E) ;
  1.  I '$G(P) Q ""
  1.  I '$D(^AUPNVELD("AC",P)) Q ""
  1.  NEW X,Y,D,G
  1.  K G S X=0,G="" F  S X=$O(^AUPNVELD("AC",P,X)) Q:X'=+X  D
  1.  .S V=$P(^AUPNVELD(X,0),U,3),D=$P($P(^AUPNVSIT(V,0),U),".")
  1.  .Q:D<B
  1.  .Q:D>E
  1.  .S G(9999999-D)=X
  1.  .Q
  1.  I $O(G(0))="" Q ""
  1.  S X=0,X=$O(G(X)) Q G(X)
  1. NUMV(P,E) ;
  1.  I '$G(P) Q ""
  1.  ;calcualte 3 yrs prior to E
  1.  NEW B
  1.  S B=$$FMADD^XLFDT(E,-(3*365))
  1.  NEW X,J,APCL,Y
  1.  S Y="APCL("
  1.  S X=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(B)_"-"_$$FMTE^XLFDT(E) S J=$$START1^APCLDF(X,Y)
  1.  S (X,Y)=0
  1.  F  S X=$O(APCL(X)) Q:X'=+X  S Y=Y+1
  1.  K APCL
  1.  Q Y
  1.  ;
  1. PRINT ;EP - called from xbdbque
  1.  K APCLQ
  1.  S APCL80D="-------------------------------------------------------------------------------"
  1.  S APCLPG=0
  1.  I '$D(^XTMP("APCLEL3",APCLJOB,APCLBTH)) D HEAD W !!,"NO DATA TO REPORT" G DONE
  1.  D TALLY
  1.  D DONE
  1.  Q
  1. TALLY ;
  1.  D HEAD
  1.  W !!,"Total Number of Patients:  ",APCLPTOT
  1.  S APCLA=0 F  S APCLA=$O(^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLA)) Q:APCLA=""!($D(APCLQ))  D
  1.  .I $Y>(IOSL-4) D HEAD Q:$D(APCLQ)
  1.  .W !!?2,$P(^DD(9000010.35,APCLA,0),U)
  1.  .S V=^XTMP("APCLEL3",APCLJOB,APCLBTH,"TALLY",APCLA)
  1.  .S T=$P(V,U,1)+$P(V,U,2)+$P(V,U,3)+$P(V,U,4)
  1.  .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)),"%"
  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)),"%"
  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)),"%"
  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)),"%"
  1.  .Q
  1.  Q
  1. DONE ;
  1.  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
  1.  W:$D(IOF) @IOF
  1.  K ^XTMP("APCLEL3",APCLJOB,APCLBTH),APCLJOB,APCLBTH
  1.  Q
  1.  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
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF S APCLPG=APCLPG+1
  1.  W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
  1.  W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!
  1.  W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
  1.  W $$CTR("TALLY OF ELDER CARE DATA ITEMS",80),!
  1.  S X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80)
  1.  W !,APCL80D
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------