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

APCLDR1.m

Go to the documentation of this file. 
  1. APCLDR1 ; IHS/CMI/LAB - patients w/o dm on problem list ;
  1.  ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ;
  1. START ;
  1.  D INFORM
  1.  D EXIT
  1.  D GETINFO
  1.  I $D(APCLQUIT) D EXIT Q
  1.  Q
  1. INFORM ;
  1.  W:$D(IOF) @IOF
  1.  W !,$$CTR($$LOC)
  1.  W !,$$CTR($$USR)
  1.  W !!,"This report will list patients who do not have Diabetes on their Problem List ",!,"but who are on a Diabetes Register or who have had at least N diagnoses of ",!,"diabetes.",!!
  1.  Q
  1.  ;
  1. GETINFO ;
  1.  S (APCLTR,APCLREG,APCLSTAT,APCLND)=""
  1.  S DIR(0)="S^R:Those who are members of a Register;D:Those with at least N Diabetes Diagnoses",DIR("A")="List which subset of patients",DIR("B")="R" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S APCLQUIT="" Q
  1.  S APCLTR=Y
  1.  D @Y
  1.  I $D(APCLQUIT) D EXIT Q
  1.  D ZIS
  1.  Q
  1. R ;
  1.  S APCLREG=""
  1.  S DIC="^ACM(41.1,",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Register: " D ^DIC
  1.  I Y=-1 W !,"No register selected." S APCLQUIT="" Q
  1.  S APCLREG=+Y
  1.  ;get status
  1.  S APCLSTAT=""
  1.  S DIR(0)="Y",DIR("A")="Do you want to select register patients with a particular status",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G R
  1.  I Y=0 S APCLSTAT="" Q
  1.  ;which status
  1.  S DIR(0)="9002241,1",DIR("A")="Which status",DIR("B")="A" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G R
  1.  S APCLSTAT=Y
  1.  Q
  1. D ;
  1.  ;how many
  1.  S APCLND=""
  1.  S DIR(0)="N^1:999:0",DIR("A")="How many diagnoses must the patient have had",DIR("B")="3" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S APCLQUIT="" Q
  1.  S APCLND=Y
  1. DATE ;
  1.  W !!,"If you are interested in restricting your list to only those patients",!,"whose most recent Diabetes diagnosis is since a certain date, enter that date.",!
  1.  W "If not, press enter or return to list all patients with at least ",APCLND," diagnoses.",!
  1.  S DIR(0)="DO^::EP",DIR("A")="Enter Date" KILL DA D ^DIR KILL DIR
  1.  I $D(DUOUT) G D
  1.  I X="^" G D
  1.  S APCLLDAT=Y
  1.  Q
  1. ZIS ;call to XBDBQUE
  1. DEMO ;
  1.  D DEMOCHK^APCLUTL(.APCLDEMO)
  1.  I APCLDEMO=-1 G DATE
  1.  S XBRP="PRINT^APCLDR1",XBRC="PROC^APCLDR1",XBRX="EXIT^APCLDR1",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("APCLDR1",APCLJOB,APCLBTH)
  1.  D XTMP^APCLOSUT("APCLDR1","DM NOT ON PROBLEM LIST")
  1.  I APCLTR="R" D REGPROC Q
  1.  I APCLTR="D" D DXPROC Q
  1.  Q
  1. DXPROC ;
  1.  ;get last dm dx, if less than last date, Q
  1.  ;if null Q
  1.  ;get # of dxs, if less than apclnd q
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D CHK1SET
  1.  Q
  1. CHK1SET ;
  1.  Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
  1.  Q:$$DOD^AUPNPAT(DFN)]""
  1.  Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)]""  ;IHS/CMI/GRL
  1.  Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)=""  ;IHS/CMI/GRL
  1.  I $$DMPROB(DFN) Q
  1.  S APCLN=$$LASTDMDX(DFN)
  1.  I APCLN="" Q
  1.  I APCLN<APCLLDAT Q
  1.  S APCLN1=$$NUMDXS(DFN)
  1.  I APCLN1<APCLND Q
  1.  S ^XTMP("APCLDR1",APCLJOB,APCLBTH,"PATIENTS",$P(^DPT(DFN,0),U),DFN)=APCLN_U_APCLN1
  1.  Q
  1. LASTDMDX(P) ;
  1.  I '$G(P) Q ""
  1.  NEW X,E,APCL,Y
  1.  S Y="APCL("
  1.  S X=P_"^LAST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y)
  1.  I $D(APCL(1)) Q $P(APCL(1),U)
  1.  Q ""
  1.  ;
  1. NUMDXS(P) ;
  1.  I '$G(P) Q ""
  1.  NEW X,E,APCL,Y
  1.  S Y="APCL("
  1.  S X=P_"^ALL DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y)
  1.  S (X,Y)=0
  1.  F  S X=$O(APCL(X)) Q:X'=+X  S Y=Y+1
  1.  Q Y
  1.  ;
  1. REGPROC ;
  1.  ;$o through register, check status, if no DM on problem list
  1.  ;set xtmp
  1.  ;gather up patients from register in ^XTMP
  1.  S X=0 F  S X=$O(^ACM(41,"B",APCLREG,X)) Q:X'=+X  D
  1.  .I APCLSTAT]"",$P($G(^ACM(41,X,"DT")),U,1)=APCLSTAT S DFN=$P(^ACM(41,X,0),U,2) D CHKSET Q
  1.  .I APCLSTAT="" S DFN=$P(^ACM(41,X,0),U,2) D CHKSET Q
  1.  .Q
  1.  Q
  1. CHKSET ;
  1.  Q:$$DOD^AUPNPAT(DFN)]""
  1.  Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)]""   ;IHS/CMI/GRL
  1.  Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)=""   ;IHS/CMI/GRL
  1.  I $$DMPROB(DFN) Q
  1.  S ^XTMP("APCLDR1",APCLJOB,APCLBTH,"PATIENTS",$P(^DPT(DFN,0),U),DFN)=$$LASTDMDX(DFN)_U_$$NUMDXS(DFN)
  1.  Q
  1. DMPROB(P) ;is DM on problem list 1=yes 0=no
  1.  I '$G(P) Q 0
  1.  I '$D(^AUPNPROB("AC",P)) Q 0
  1.  NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
  1.  I 'T Q ""
  1.  NEW G,D,Y,I S D="",(Y,G)=0 F  S Y=$O(^AUPNPROB("AC",P,Y)) Q:Y'=+Y!(G)  D
  1.  .S I=$P(^AUPNPROB(Y,0),U)
  1.  .I $$ICD^ATXAPI(I,T,9) S G=1
  1.  .Q
  1.  Q G
  1. PRINT ;EP - called from xbdbque
  1.  S APCLIOSL=$S($G(APCLGUI):55,1:IOSL)
  1.  S APCL80D="-------------------------------------------------------------------------------"
  1.  S APCLPG=0 D HEAD
  1.  I '$D(^XTMP("APCLDR1",APCLJOB,APCLBTH)) W !!,"NO PATIENTS TO REPORT" G DONE
  1.  S APCLNAME="" K APCLQ
  1.  F  S APCLNAME=$O(^XTMP("APCLDR1",APCLJOB,APCLBTH,"PATIENTS",APCLNAME)) Q:APCLNAME=""!($D(APCLQ))  D
  1.  .S DFN="" F  S DFN=$O(^XTMP("APCLDR1",APCLJOB,APCLBTH,"PATIENTS",APCLNAME,DFN)) Q:DFN=""!($D(APCLQ))  S APCLX=^XTMP("APCLDR1",APCLJOB,APCLBTH,"PATIENTS",APCLNAME,DFN) D
  1.  ..I $Y>(APCLIOSL-4) D HEAD Q:$D(APCLQ)
  1.  ..W !,$E(APCLNAME,1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$DOB^AUPNPAT(DFN,"E"),?43,$P(^DPT(DFN,0),U,2),?47,$$FMTE^XLFDT($P(APCLX,U)),?63,$P(APCLX,U,2)
  1. DONE ;
  1.  I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report.  HIT RETURN" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  W:$D(IOF) @IOF
  1.  K ^XTMP("APCLDR1",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.  I $G(APCLGUI),APCLPG'=1 W !,"ZZZZZZZ"
  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 NO DIAGNOSIS OF DIABETES ON PROBLEM LIST",80),!
  1.  I APCLTR="R" W $$CTR("Patients on the "_$P(^ACM(41.1,APCLREG,0),U)_" Register",80),!
  1.  I APCLTR="D" W $$CTR("Patients w/at least "_APCLND_" diabetes diagnoses",80),!
  1. PIH W !,"PATIENT NAME",?22,"HRN",?29,"DOB",?47,"LAST DM DX",?63,"# OF DM DXS",!,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.  ;----------
  1. TEST ;
  1.  D BDMG("R",1,"A")
  1.  Q
  1. BDMG(APCLTR,APCLREG,APCLSTAT,APCLND,APCLLDAT) ;EP - GUI DMS Entry Point
  1.  S APCLND=$G(APCLND)
  1.  S APCLGUI=1
  1.  S APCLLDAT=$G(APCLLDAT)
  1.  NEW APCLNOW,APCLOPT,APCLIEN
  1.  S APCLOPT="Patients w/no Diagnosis of DM on Problem Lis"
  1.  D NOW^%DTC
  1.  S APCLNOW=$G(%)
  1.  K DD,DO,DIC
  1.  S X=DUZ_APCLNOW
  1.  S DIC("DR")=".02////"_DUZ_";.03////"_APCLNOW_";.06///"_$G(APCLOPT)_";.07////R"
  1.  S DIC="^APCLGUIR(",DIC(0)="L",DIADD=1,DLAYGO=9001004.4
  1.  D FILE^DICN
  1.  K DIADD,DLAYGO,DIC,DA
  1.  I Y=-1 S APCLIEN=-1 Q
  1.  S APCLIEN=+Y
  1.  S BDMGIEN=APCLIEN  ;cmi/maw added
  1.  D ^XBFMK
  1.  K ZTSAVE S ZTSAVE("*")=""
  1.  ;D GUIEP for interactive testing
  1.  S ZTIO="",ZTDTH=$$NOW^XLFDT,ZTRTN="GUIEP^APCLDR1",ZTDESC="GUI DM PTS NO DX PL" D ^%ZTLOAD
  1.  D EXIT
  1.  Q
  1. GUIEP ;EP
  1.  D PROC
  1.  K ^TMP($J,"APCLDR1")
  1.  S IOM=80
  1.  D GUIR^XBLM("PRINT^APCLDR1","^TMP($J,""APCLDR1"",")
  1.   S X=0,C=0 F  S X=$O(^TMP($J,"APCLDR1",X)) Q:X'=+X  D
  1.  .S APCLDATA=^TMP($J,"APCLDR1",X)
  1.  .I APCLDATA="ZZZZZZZ" S APCLDATA=$C(12)
  1.  .S ^APCLGUIR(APCLIEN,11,X,0)=APCLDATA,C=C+1
  1.  S ^APCLGUIR(APCLIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
  1.  S DA=APCLIEN,DIK="^APCLGUIR(" D IX1^DIK
  1.  D ENDLOG
  1.  K ^TMP($J,"APCLDR1")
  1.  D EXIT
  1.  S ZTREQ="@"
  1.  Q
  1.  ;
  1. ENDLOG ;-- write the end of the log
  1.  D NOW^%DTC
  1.  S APCLNOW=$G(%)
  1.  S DIE="^APCLGUIR(",DA=APCLIEN,DR=".04////"_APCLNOW_";.07////C"
  1.  D ^DIE
  1.  K DIE,DR,DA
  1.  Q