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

BDMDR1.m

Go to the documentation of this file. 
  1. BDMDR1 ; IHS/CMI/LAB - patients w/o dm on problem list ;
  1.  ;;2.0;DIABETES MANAGEMENT SYSTEM;**2,3,8,10**;JUN 14, 2007;Build 12
  1.  ;
  1.  ;
  1. START ;
  1.  D INFORM
  1.  D EXIT
  1.  D GETINFO
  1.  I $D(BDMQUIT) 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 (BDMTR,BDMREG,BDMSTAT,BDMND)=""
  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 BDMQUIT="" Q
  1.  S BDMTR=Y
  1.  D @Y
  1.  I $D(BDMQUIT) D EXIT Q
  1.  D ZIS
  1.  Q
  1. R ;
  1.  S BDMREG=""
  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 BDMQUIT="" Q
  1.  S BDMREG=+Y
  1.  ;get status
  1.  S BDMSTAT=""
  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 BDMSTAT="" 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 BDMSTAT=Y
  1.  Q
  1. D ;
  1.  ;how many
  1.  S BDMND=""
  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 BDMQUIT="" Q
  1.  S BDMND=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 ",BDMND," 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 BDMLDAT=Y
  1.  Q
  1. ZIS ;
  1.  S BDMTEMP=""
  1.  S DIR(0)="S^P:PRINT the List;B:BROWSE the List on the Screen",DIR("A")="Output Type",DIR("B")="P" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  S BDMTEMP=Y
  1.  ;call to XBDBQUE
  1. DEMO ;
  1.  D DEMOCHK^BDMUTL(.BDMDEMO)
  1.  I BDMDEMO=-1 D EXIT Q
  1.  I BDMTEMP="B" D BROWSE,EXIT Q
  1.  S XBRP="PRINT^BDMDR1",XBRC="PROC^BDMDR1",XBRX="EXIT^BDMDR1",XBNS="BDM"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""PRINT^BDMDR1"")"
  1.  S XBRC="PROC^BDMDR1",XBRX="EXIT^BDMDR1",XBIOP=0 D ^XBDBQUE
  1.  Q
  1. EXIT ;clean up and exit
  1.  I '$D(BDMGUI) D EN^XBVK("BDM")
  1.  D ^XBFMK
  1.  D KILL^AUPNPAT
  1.  Q
  1. PROC ;EP - called from XBDBQUE
  1.  S BDMJOB=$J,BDMBTH=$H
  1.  K ^XTMP("BDMDR1",BDMJOB,BDMBTH)
  1.  D XTMP^BDMOSUT("BDMDR1","DM NOT ON PROBLEM LIST")
  1.  I BDMTR="R" D REGPROC Q
  1.  I BDMTR="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 BDMnd q
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D CHK1SET
  1.  Q
  1. CHK1SET ;
  1.  Q:$$DEMO^BDMUTL(DFN,$G(BDMDEMO))
  1.  Q:$$DOD^AUPNPAT(DFN)]""
  1.  Q:$P($G(^AUPNPAT(DFN,41,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,5)]""  ;IHS/CMI/GRL
  1.  Q:$P($G(^AUPNPAT(DFN,41,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,2)=""  ;IHS/CMI/GRL
  1.  I $$DMPROB(DFN) Q
  1.  S BDMN=$$LASTDMDX(DFN)
  1.  I BDMN="" Q
  1.  I BDMN<BDMLDAT Q
  1.  S BDMN1=$$NUMDXS(DFN)
  1.  I BDMN1<BDMND Q
  1.  S ^XTMP("BDMDR1",BDMJOB,BDMBTH,"PATIENTS",$P(^DPT(DFN,0),U),DFN)=BDMN_U_BDMN1
  1.  Q
  1. LASTDMDX(P) ;
  1.  I '$G(P) Q ""
  1.  NEW X,E,BDM,Y
  1.  S Y="BDM("
  1.  S X=P_"^LAST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y)
  1.  I $D(BDM(1)) Q $P(BDM(1),U)
  1.  Q ""
  1.  ;
  1. NUMDXS(P) ;
  1.  I '$G(P) Q ""
  1.  NEW X,E,BDM,Y
  1.  S Y="BDM("
  1.  S X=P_"^ALL DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y)
  1.  S (X,Y)=0
  1.  F  S X=$O(BDM(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",BDMREG,X)) Q:X'=+X  D
  1.  .I BDMSTAT]"",$P($G(^ACM(41,X,"DT")),U,1)=BDMSTAT S DFN=$P(^ACM(41,X,0),U,2) D CHKSET Q
  1.  .I BDMSTAT="" 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,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,5)]""   ;IHS/CMI/GRL
  1.  Q:$P($G(^AUPNPAT(DFN,41,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,2)=""   ;IHS/CMI/GRL
  1.  I $$DMPROB(DFN) Q
  1.  S ^XTMP("BDMDR1",BDMJOB,BDMBTH,"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.  .Q:$P(^AUPNPROB(Y,0),U,12)="D"
  1.  .S I=$P(^AUPNPROB(Y,0),U)
  1.  .I $$ICD^ATXCHK(I,T,9) S G=1
  1.  .Q
  1.  Q G
  1. PRINT ;EP - called from xbdbque
  1.  S BDMIOSL=$S($G(BDMGUI):55,1:IOSL)
  1.  S BDM80D="-------------------------------------------------------------------------------"
  1.  S BDMPG=0 D HEAD
  1.  I '$D(^XTMP("BDMDR1",BDMJOB,BDMBTH)) W !!,"NO PATIENTS TO REPORT" G DONE
  1.  S BDMNAME="" K BDMQ
  1.  F  S BDMNAME=$O(^XTMP("BDMDR1",BDMJOB,BDMBTH,"PATIENTS",BDMNAME)) Q:BDMNAME=""!($D(BDMQ))  D
  1.  .S DFN="" F  S DFN=$O(^XTMP("BDMDR1",BDMJOB,BDMBTH,"PATIENTS",BDMNAME,DFN)) Q:DFN=""!($D(BDMQ))  S BDMX=^XTMP("BDMDR1",BDMJOB,BDMBTH,"PATIENTS",BDMNAME,DFN) D
  1.  ..I $Y>(BDMIOSL-4) D HEAD Q:$D(BDMQ)
  1.  ..W !,$E(BDMNAME,1,20),?22,$$HRN^AUPNPAT(DFN,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2))),?29,$$DOB^AUPNPAT(DFN,"E"),?43,$P(^DPT(DFN,0),U,2),?47,$$FMTE^XLFDT($P(BDMX,U)),?63,$P(BDMX,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("BDMDR1",BDMJOB,BDMBTH),BDMJOB,BDMBTH
  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 BDMQ="" Q
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF S BDMPG=BDMPG+1
  1.  I $G(BDMGUI),BDMPG'=1 W !,"ZZZZZZZ"
  1.  W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
  1.  W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",BDMPG,!
  1.  W ?(80-$L($P(^DIC(4,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U))/2),$P(^DIC(4,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U),!
  1.  W $$CTR("PATIENTS WITH NO DIAGNOSIS OF DIABETES ON PROBLEM LIST",80),!
  1.  I BDMTR="R" W $$CTR("Patients on the "_$P(^ACM(41.1,BDMREG,0),U)_" Register",80),!
  1.  I BDMTR="D" W $$CTR("Patients w/at least "_BDMND_" diabetes diagnoses",80),!
  1. PIH W !,"PATIENT NAME",?22,"HRN",?29,"DOB",?47,"LAST DM DX",?63,"# OF DM DXS",!,BDM80D
  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(BDMTR,BDMREG,BDMSTAT,BDMND,BDMLDAT) ;EP - GUI DMS Entry Point
  1.  S BDMND=$G(BDMND)
  1.  S BDMGUI=1
  1.  S BDMLDAT=$G(BDMLDAT)
  1.  NEW BDMNOW,BDMOPT,BDMIEN
  1.  S BDMOPT="Patients w/no Diagnosis of DM on Problem Lis"
  1.  D NOW^%DTC
  1.  S BDMNOW=$G(%)
  1.  K DD,DO,DIC
  1.  S X=DUZ_BDMNOW
  1.  S DIC("DR")=".02////"_DUZ_";.03////"_BDMNOW_";.06///"_$G(BDMOPT)_";.07////R"
  1.  S DIC="^BDMGUI(",DIC(0)="L",DIADD=1,DLAYGO=9003201.4
  1.  D FILE^DICN
  1.  K DIADD,DLAYGO,DIC,DA
  1.  I Y=-1 S BDMIEN=-1 Q
  1.  S BDMIEN=+Y
  1.  S BDMGIEN=BDMIEN  ;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^BDMDR1",ZTDESC="GUI DM PTS NO DX PL" D ^%ZTLOAD
  1.  D EXIT
  1.  Q
  1. GUIEP ;EP
  1.  D PROC
  1.  K ^TMP($J,"BDMDR1")
  1.  S IOM=80
  1.  D GUIR^XBLM("PRINT^BDMDR1","^TMP($J,""BDMDR1"",")
  1.   S X=0,C=0 F  S X=$O(^TMP($J,"BDMDR1",X)) Q:X'=+X  D
  1.  .S BDMDATA=^TMP($J,"BDMDR1",X)
  1.  .;I BDMDATA="ZZZZZZZ" ;S BDMDATA=$C(12)
  1.  .S ^BDMGUI(BDMIEN,11,X,0)=BDMDATA,C=C+1
  1.  S ^BDMGUI(BDMIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
  1.  S DA=BDMIEN,DIK="^BDMGUI(" D IX1^DIK
  1.  D ENDLOG
  1.  K ^TMP($J,"BDMDR1")
  1.  D EXIT
  1.  S ZTREQ="@"
  1.  Q
  1.  ;
  1. ENDLOG ;-- write the end of the log
  1.  D NOW^%DTC
  1.  S BDMNOW=$G(%)
  1.  S DIE="^BDMGUI(",DA=BDMIEN,DR=".04////"_BDMNOW_";.07////C"
  1.  D ^DIE
  1.  K DIE,DR,DA
  1.  Q