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

APCLEL1.m

Go to the documentation of this file. 
  1. 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
  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 by age/sex, all patients who have had a functional",!,"assessment in a date range you specify.  You will also specity what age"
  1.  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 "
  1.  W "patients who live a particular community or set of communities",!,"and to specify the minimum number of times the must have been seen"
  1.  W !,"in the 3 years prior to the end of your date range in order to be included ",!,"in the report.",!
  1.  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.",!!
  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. AGE ;what age range of patients
  1.  W !,"Please enter the age range of patients you are interested in."
  1.  W !
  1.  S DIR(0)="F^1:7",DIR("A")="Enter an Age Range (e.g. 55-100,55-75)" D ^DIR K DIR
  1.  I $D(DIRUT) G DATE
  1.  I Y="" W !!,"No age range entered." G DATE
  1.  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
  1.  I $P(Y,"-",2)>130 W !,"Enter an age range, maximum age 130",! G AGE
  1.  S APCLAGET=Y
  1. CMMNTS ;
  1.  K APCLCOMM
  1.  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
  1.  G:$D(DIRUT) AGE
  1.  I Y="A" W !!,"Patients from all communities will be included in the report.",! G NV
  1.  I Y="O" D  G:'$D(APCLCOMM) CMMNTS G NV
  1.  .K APCLCOMM
  1.  .S DIC="^AUTTCOM(",DIC(0)="AEMQ",DIC("A")="Which COMMUNITY: " D ^DIC K DIC
  1.  .Q:Y=-1
  1.  .S APCLCOMM($P(^AUTTCOM(+Y,0),U))=""
  1.  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
  1.  D PEP^AMQQGTX0(+Y,"APCLCOMM(")
  1.  I '$D(APCLCOMM) G CMMNTS
  1.  I $D(APCLCOMM("*")) K APCLCOMM G CMMNTS
  1.  ;
  1. NV ;
  1.  W !!,"In order to determine 'active' patients please indicate the minimum number of"
  1.  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.",!
  1.  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
  1.  I $D(DIRUT) G CMMNTS
  1.  S APCLNV=Y
  1.  ;
  1. RPT ;
  1.  S APCLRPT=""
  1.  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
  1.  I $D(DIRUT) G NV
  1.  S APCLRPT=Y
  1.  ;
  1. ZIS ;call to XBDBQUE
  1. DEMO ;
  1.  D DEMOCHK^APCLUTL(.APCLDEMO)
  1.  I APCLDEMO=-1 G RPT
  1.  S XBRP="PRINT^APCLEL1",XBRC="PROC^APCLEL1",XBRX="EXIT^APCLEL1",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
  1.  K ^XTMP("APCLEL1",APCLJOB,APCLBTH)
  1.  D XTMP^APCLOSUT("APCLEL1","ELDER CARE TALLY")
  1.  S I=$P(APCLAGET,"-"),J=$P(APCLAGET,"-",2)
  1.  F X=I:1:J S ^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",X,"F")=0,^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",X,"M")=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.  ;set list of patients for optional report
  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.  .S AGE=$$AGE^AUPNPAT(DFN,APCLBD)
  1.  .I AGE<$P(APCLAGET,"-")!(AGE>$P(APCLAGET,"-",2)) Q
  1.  .;check community
  1.  .I $D(APCLCOMM) S C=$P($G(^AUPNPAT(DFN,11)),U,18) Q:C=""  I '$D(APCLCOMM(C)) Q
  1.  .;check number of times seen
  1.  .I $$NUMV(DFN,APCLED)<APCLNV Q
  1.  .;has pt had functional assessment
  1.  .S X=$$FA(DFN,APCLBD,APCLED)
  1.  .S ^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",AGE,$P(^DPT(DFN,0),U,2),DFN)=X
  1.  .S S=$P(^DPT(DFN,0),U,2)
  1.  .I S="U" S S="M"
  1.  .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
  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))
  1.  .Q
  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.  Q 9999999-$O(G(0))
  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("APCLEL1",APCLJOB,APCLBTH)) S APCLTR="X" D HEAD W !!,"NO PATIENTS TO REPORT" G DONE
  1.  I APCLRPT="B"!(APCLRPT="T") D TALLY
  1.  G:$D(APCLQ) DONE
  1.  I APCLRPT="B"!(APCLRPT="L") D LIST
  1.  D DONE
  1.  Q
  1. TALLY ;
  1.  S APCLTR="T",APCLTM=0,APCLTF=0
  1.  D HEAD Q:$D(APCLQ)
  1.  S APCLA=0 F  S APCLA=$O(^XTMP("APCLEL1",APCLJOB,APCLBTH,"TALLY",APCLA)) Q:APCLA=""!($D(APCLQ))  D
  1.  .I $Y>(IOSL-4) D HEAD Q:$D(APCLQ)
  1.  .W !?2,APCLA
  1.  .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)
  1.  .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)
  1.  .I $P(APCLF,U)=0 W ?20,"-",?27,"-",?33,"-"
  1.  .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
  1.  .I $P(APCLM,U)=0 W ?40,"-",?47,"-",?53,"-"
  1.  .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
  1.  .S T=$P(APCLM,U)+$P(APCLF,U),T1=$P(APCLM,U,2)+$P(APCLF,U,2)
  1.  .I T=0 W ?60,"-",?67,"-",?73,"-"
  1.  .I T>0 W ?55,$J(T1,6),?62,$J(T,6) S V=$J(((T1/T)*100),5,1) W ?69,V
  1.  Q:$D(APCLQ)
  1.  I $Y>(IOSL-3) D HEAD Q:$D(APCLQ)
  1.  W !!,"TOTAL"
  1.  I $P(APCLTF,U)=0 W ?20,"-",?27,"-",?33,"-"
  1.  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
  1.  I $P(APCLTM,U)=0 W ?40,"-",?47,"-",?53,"-"
  1.  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
  1.  S T=$P(APCLTM,U)+$P(APCLTF,U),T1=$P(APCLTM,U,2)+$P(APCLTF,U,2)
  1.  I T=0 W ?60,"-",?67,"-",?73,"-"
  1.  I T>0 W ?55,$J(T1,6),?62,$J(T,6) S V=$J(((T1/T)*100),5,1) W ?69,V
  1.  Q
  1. LIST ;
  1.  S APCLTR="L"
  1.  D HEAD Q:$D(APCLQ)
  1.  S APCLA=0 F  S APCLA=$O(^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",APCLA)) Q:APCLA'=+APCLA!($D(APCLQ))  D
  1.  .S APCLS="" F  S APCLS=$O(^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",APCLA,APCLS)) Q:APCLS=""!($D(APCLQ))  D
  1.  ..S DFN=0 F  S DFN=$O(^XTMP("APCLEL1",APCLJOB,APCLBTH,"PATIENT LIST",APCLA,APCLS,DFN)) Q:DFN'=+DFN!($D(APCLQ))  D
  1.  ...I $Y>(IOSL-3) D HEAD Q:$D(APCLQ)
  1.  ...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))
  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("APCLEL1",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("PATIENTS WITH FUNCTIONAL ASSESSMENT DOCUMENTED",80),!
  1.  S X="between "_$$FMTE^XLFDT(APCLBD)_" and "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80)
  1.  I '$D(APCLCOMM) S X="All Communities" W !,$$CTR(X)
  1.  I $D(APCLCOMM) S X="Selected Communities" W !,$$CTR(X)
  1.  W !,APCL80D
  1.  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
  1.  .W ?37,"------------------",?57,"------------------"
  1.  I APCLTR="L" W !?64,"LAST FUNCTIONAL",!,"PATIENT NAME",?28,"HRN",?36,"SEX",?41,"DOB",?59,"AGE",?64,"ASSESSMENT",!,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.  ;----------