APCLDR3 ; IHS/CMI/LAB - patients dm list - chinle ;
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;
;
START ;
D INFORM
D EXIT
D GETINFO
I $D(APCLQUIT) D EXIT Q
D ZIS
Q
INFORM ;
W:$D(IOF) @IOF
W !,$$CTR($$LOC)
W !,$$CTR($$USR)
W !!,"This report will list patients who are on the diabetes register",!,"that you select.",!,"The following data items will be printed for each patient: Name, HRN, DOB",!,"Community of Residence.",!
W !,"For each of the following tests the last value in the 4 months prior to the",!,"as of date you enter and the next most recent prior to that one will be",!,"displayed:"
W !?5,"Hbg A1C, BP, Total Cholesterol, HDL, LDL",!!
Q
;
GETINFO ;
R ;
W !!,"Patients must be a member of the Diabetes Register in order to be included in",!,"this report.",!
S APCLREG=""
S DIC="^ACM(41.1,",DIC(0)="AEMQ",DIC("A")="Enter the Name of the DM Register: " D ^DIC
I Y=-1 W !,"No register selected." S APCLQUIT="" Q
S APCLREG=+Y
;get status
S APCLSTAT=""
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
I $D(DIRUT) G R
I Y=0 S APCLSTAT="" G PCP
;which status
S DIR(0)="9002241,1",DIR("A")="Which status",DIR("B")="A" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G R
S APCLSTAT=Y,APCLSTAR=Y(0)
PCP ;
S APCLPCP=""
S DIR(0)="Y",DIR("A")="Limit the report to a particular Designated Primary Care Provider ",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G R
I 'Y G EDATE
K DIC S DIC=$S($P(^DD(9000001,.14,0),U,2)[200:200,1:6),DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1 G PCP
S APCLPCP=+Y
EDATE ;get visit date range for functional assessment
S APCLED=""
K DIR W ! S DIR(0)="D^::EXP",DIR("A")="Enter As of Date for 4 month period"
D ^DIR K DIR G:Y<1 PCP S APCLED=Y,APCLEDD=$$FMTE^XLFDT(APCLED)
S APCLBD=$$FMADD^XLFDT(APCLED,-(4*30.5))
S APCLSD=$$FMADD^XLFDT(APCLBD,-1)
;
Q
ZIS ;call to XBDBQUE
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G EDATE
S XBRP="PRINT^APCLDR31",XBRC="PROC^APCLDR3",XBRX="EXIT^APCLDR3",XBNS="APCL"
D ^XBDBQUE
D EXIT
Q
EXIT ;clean up and exit
K A,B,C,P,X,Y
D EN^XBVK("APCL")
D ^XBFMK
D KILL^AUPNPAT
Q
;
PROC ;EP - called from XBDBQUE
S APCLJOB=$J,APCLBTH=$H
K ^XTMP("APCLDR3",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLDR3","DM LIST DM PATIENTS")
D REGPROC
Q
REGPROC ;
S X=0 F S X=$O(^ACM(41,"B",APCLREG,X)) Q:X'=+X D
.I APCLSTAT]"",$P($G(^ACM(41,X,"DT")),U,1)=APCLSTAT S DFN=$P(^ACM(41,X,0),U,2) D CHKSET Q
.I APCLSTAT="" S DFN=$P(^ACM(41,X,0),U,2) D CHKSET Q
.Q
Q
CHKSET ;
Q:$$DOD^AUPNPAT(DFN)]""
Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
;I APCLPCP,$P(^AUPNPAT(DFN,0),U,14)'=APCLPCP Q
S P=$$VAL^XBDIQ1(9000001,DFN,.14),P=$S(P]"":P,1:"???")
S P1=$$VALI^XBDIQ1(9000001,DFN,.14)
S C=$$COMMRES^AUPNPAT(DFN,"E"),C=$S(C]"":C,1:"???")
S ^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",P,C,$P(^DPT(DFN,0),U),DFN)=$S(P1:P1,1:"???")
Q
C(X,X2,X3) ;
D COMMA^%DTC
Q X
DATE(B) ;
I $G(B)="" Q ""
Q $E(B,4,5)_"/"_$E(B,6,7)_"/"_$E(B,2,3)
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")
;----------
POST ;EP
S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM PTS 4 MONTHS","DMV")
I 'X W "Attempt to add Patients w/selected values in 4 months option failed.." H 3
Q
SUBTOT ;EP
Q:'APCLWR
S APCLSUB=""
I $Y>(APCLIOSL-9) D HEAD^APCLDR31 Q:$D(APCLQ)
W !,"Subtotals for "_$E(APCLP,1,16)_": ",?37,"# Patients",?50," # w/item done",?70,"%"
W !?2,"Last Clinic Visit",?38,$J($$C(APCLSTOT(0),0,8),9),?52,$J($$C($G(APCLSTOT(1)),0,8),9)
S X=($G(APCLSTOT(1))/APCLSTOT(0))*100
W ?67,$J(X,6,2)
W !?2,"Blood Pressure",?38,$J($$C(APCLSTOT(0),0,8),9),?52,$J($$C($G(APCLSTOT(2)),0,8),9)
S X=($G(APCLSTOT(2))/APCLSTOT(0))*100
W ?67,$J(X,6,2)
W !?2,"HGB A1C",?38,$J($$C(APCLSTOT(0),0,8),9),?52,$J($$C($G(APCLSTOT(3)),0,8),9)
S X=($G(APCLSTOT(3))/APCLSTOT(0))*100
W ?67,$J(X,6,2)
W !?2,"Total Cholesterol",?38,$J($$C(APCLSTOT(0),0,8),9),?52,$J($$C($G(APCLSTOT(4)),0,8),9)
S X=($G(APCLSTOT(4))/APCLSTOT(0))*100
W ?67,$J(X,6,2)
W !?2,"LDL Cholesterol",?38,$J($$C(APCLSTOT(0),0,8),9),?52,$J($$C($G(APCLSTOT(5)),0,8),9)
S X=($G(APCLSTOT(5))/APCLSTOT(0))*100
W ?67,$J(X,6,2)
W !?2,"HDL Cholesterol",?38,$J($$C(APCLSTOT(0),0,8),9),?52,$J($$C($G(APCLSTOT(6)),0,8),9)
S X=($G(APCLSTOT(6))/APCLSTOT(0))*100
W ?67,$J(X,6,2)
K APCLSUB
Q
FINH ;
W !,$$CTR("Value Totals/Comparisons for: "_APCLP,80),!
W !?35,"PROVIDER SPECIFIC",?56,"TOTAL REGISTER",!
W ?35,"# pats",?48,"%",?56,"# pats",?68,"%",!
Q
FINTOT ;EP
S APCLFINL=""
;print page for each provider from APCLHGB, ETC
S APCLP="" F S APCLP=$O(APCLTHGB(APCLP)) Q:APCLP=""!($D(APCLQ)) D
.S APCLP1="" F S APCLP1=$O(APCLTHGB(APCLP,APCLP1)) Q:APCLP1="" D FINTOT1
Q
FINTOT1 ;
I APCLPCP,APCLP1'=APCLPCP Q
;header, then print and calculate
D HEAD^APCLDR31
Q:$D(APCLQ)
D FINH
S APCLTOTP=$P(APCLTHGB,U),APCLTOPP=$P(APCLTHGB(APCLP,APCLP1),U)
W !,"Total Number of Patients",?33,$J($$C(APCLTOPP,0,8),9),?53,$J($$C(APCLTOTP,0,8),9),!
W !,"Blood Glucose Control"
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTHGB(APCLP,APCLP1),U,2),APCLTN=$P(APCLTHGB,U,2) W !?2,"HbA1c <7.0" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTHGB(APCLP,APCLP1),U,3),APCLTN=$P(APCLTHGB,U,3) W !?8,"7.0-7.9" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTHGB(APCLP,APCLP1),U,4),APCLTN=$P(APCLTHGB,U,4) W !?8,"8.0-8.9" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTHGB(APCLP,APCLP1),U,5),APCLTN=$P(APCLTHGB,U,5) W !?8,"9.0-9.9" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTHGB(APCLP,APCLP1),U,6),APCLTN=$P(APCLTHGB,U,6) W !?8,"10.0-10.9" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTHGB(APCLP,APCLP1),U,7),APCLTN=$P(APCLTHGB,U,7) W !?8,"11.0 or higher" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTHGB(APCLP,APCLP1),U,8),APCLTN=$P(APCLTHGB,U,8) W !?8,"Tested but no value" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTHGB(APCLP,APCLP1),U,9),APCLTN=$P(APCLTHGB,U,9) W !?8,"Not tested in 4 months" D W
FINBP ;
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
W !!,"Blood Pressure Control"
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTBP(APCLP,APCLP1),U,2),APCLTN=$P(APCLTBP,U,2) W !?8,"<120/80" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTBP(APCLP,APCLP1),U,3),APCLTN=$P(APCLTBP,U,3) W !?8,"120/80-<130/85" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTBP(APCLP,APCLP1),U,4),APCLTN=$P(APCLTBP,U,4) W !?8,"130/85-<140/90" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTBP(APCLP,APCLP1),U,5),APCLTN=$P(APCLTBP,U,5) W !?8,"140/90-<160/95" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTBP(APCLP,APCLP1),U,6),APCLTN=$P(APCLTBP,U,6) W !?8,"160/95 or higher" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTBP(APCLP,APCLP1),U,7),APCLTN=$P(APCLTBP,U,7) W !?8,"Not tested in 4 months" D W
FINLDL ;
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
W !!,"LDL Cholesterol"
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTLDL(APCLP,APCLP1),U,2),APCLTN=$P(APCLTLDL,U,2) W !?8,"<100 mg/dl" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTLDL(APCLP,APCLP1),U,3),APCLTN=$P(APCLTLDL,U,3) W !?8,"100-129 mg/dl" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTLDL(APCLP,APCLP1),U,4),APCLTN=$P(APCLTLDL,U,4) W !?8,"130-160 mg/dl" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTLDL(APCLP,APCLP1),U,5),APCLTN=$P(APCLTLDL,U,5) W !?8,">160 mg/dl" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTLDL(APCLP,APCLP1),U,6),APCLTN=$P(APCLTLDL,U,6) W !?8,"Tested but no value" D W
I $Y>(APCLIOSL-4) D HEAD^APCLDR31 Q:$D(APCLQ) D FINH
S APCLPN=$P(APCLTLDL(APCLP,APCLP1),U,7),APCLTN=$P(APCLTLDL,U,7) W !?8,"Not tested in 15 months" D W
Q
W ;
W ?33,$J($$C(APCLPN,0,8),9),?45,$$PER(APCLPN,APCLTOPP),?53,$J($$C(APCLTN,0,8),9),?65,$$PER(APCLTN,APCLTOTP)
Q
PER(N,D) ;n=numerator, d=denominator
I $G(D)="" Q ""
I $G(D)=0 Q ""
NEW X,Y,Z
S X=N/D,X=X*100,X=$J(X,5,1)
Q X
;
TEST ;
D BDMG(1,"A",,DT,"ACTIVE")
Q
BDMG(APCLREG,APCLSTAT,APCLPCP,APCLED,APCLSTAR) ;EP - GUI DMS Entry Point
;cmi/anch/maw added 10/19/2004
S APCLEDD=$$FMTE^XLFDT(APCLED)
S APCLGUI=1
S APCLBD=$$FMADD^XLFDT(APCLED,-(4*30.5))
S APCLSD=$$FMADD^XLFDT(APCLBD,-1)
S APCLPCP=$G(APCLPCP)
NEW APCLNOW,APCLOPT,APCLIEN
S APCLOPT="DM Register Patients and Select Values in 4 Months"
D NOW^%DTC
S APCLNOW=$G(%)
K DD,DO,DIC
S X=DUZ_APCLNOW
S DIC("DR")=".02////"_DUZ_";.03////"_APCLNOW_";.06///"_$G(APCLOPT)_";.07////R"
S DIC="^APCLGUIR(",DIC(0)="L",DIADD=1,DLAYGO=9001004.4
D FILE^DICN
K DIADD,DLAYGO,DIC,DA
I Y=-1 S APCLIEN=-1 Q
S APCLIEN=+Y
S BDMGIEN=APCLIEN ;cmi/maw added
D ^XBFMK
K ZTSAVE S ZTSAVE("*")=""
;D GUIEP for interactive testing
S ZTIO="",ZTDTH=$$NOW^XLFDT,ZTRTN="GUIEP^APCLDR3",ZTDESC="GUI DM 4 MONTHS" D ^%ZTLOAD
D EXIT
Q
GUIEP ;EP
D PROC
K ^TMP($J,"APCLDR3")
S IOM=80
D GUIR^XBLM("PRINT^APCLDR31","^TMP($J,""APCLDR3"",")
S X=0,C=0 F S X=$O(^TMP($J,"APCLDR3",X)) Q:X'=+X D
.S APCLDATA=^TMP($J,"APCLDR3",X)
.I APCLDATA="ZZZZZZZ" S APCLDATA=$C(12)
.S ^APCLGUIR(APCLIEN,11,X,0)=APCLDATA,C=C+1
S ^APCLGUIR(APCLIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
S DA=APCLIEN,DIK="^APCLGUIR(" D IX1^DIK
D ENDLOG
K ^TMP($J,"APCLDR3")
D EXIT
S ZTREQ="@"
Q
;
ENDLOG ;-- write the end of the log
D NOW^%DTC
S APCLNOW=$G(%)
S DIE="^APCLGUIR(",DA=APCLIEN,DR=".04////"_APCLNOW_";.07////C"
D ^DIE
K DIE,DR,DA
Q
APCLDR3 ; IHS/CMI/LAB - patients dm list - chinle ;
+1 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+2 ;
+3 ;
START ;
+1 DO INFORM
+2 DO EXIT
+3 DO GETINFO
+4 IF $DATA(APCLQUIT)
DO EXIT
QUIT
+5 DO ZIS
+6 QUIT
INFORM ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC)
+3 WRITE !,$$CTR($$USR)
+4 WRITE !!,"This report will list patients who are on the diabetes register",!,"that you select.",!,"The following data items will be printed for each patient: Name, HRN, DOB",!,"Community of Residence.",!
+5 WRITE !,"For each of the following tests the last value in the 4 months prior to the",!,"as of date you enter and the next most recent prior to that one will be",!,"displayed:"
+6 WRITE !?5,"Hbg A1C, BP, Total Cholesterol, HDL, LDL",!!
+7 QUIT
+8 ;
GETINFO ;
R ;
+1 WRITE !!,"Patients must be a member of the Diabetes Register in order to be included in",!,"this report.",!
+2 SET APCLREG=""
+3 SET DIC="^ACM(41.1,"
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the Name of the DM Register: "
DO ^DIC
+4 IF Y=-1
WRITE !,"No register selected."
SET APCLQUIT=""
QUIT
+5 SET APCLREG=+Y
+6 ;get status
+7 SET APCLSTAT=""
+8 SET DIR(0)="Y"
SET DIR("A")="Do you want to select register patients with a particular status"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
GOTO R
+10 IF Y=0
SET APCLSTAT=""
GOTO PCP
+11 ;which status
+12 SET DIR(0)="9002241,1"
SET DIR("A")="Which status"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+13 IF $DATA(DIRUT)
GOTO R
+14 SET APCLSTAT=Y
SET APCLSTAR=Y(0)
PCP ;
+1 SET APCLPCP=""
+2 SET DIR(0)="Y"
SET DIR("A")="Limit the report to a particular Designated Primary Care Provider "
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO R
+4 IF 'Y
GOTO EDATE
+5 KILL DIC
SET DIC=$SELECT($PIECE(^DD(9000001,.14,0),U,2)[200:200,1:6)
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+6 IF Y=-1
GOTO PCP
+7 SET APCLPCP=+Y
EDATE ;get visit date range for functional assessment
+1 SET APCLED=""
+2 KILL DIR
WRITE !
SET DIR(0)="D^::EXP"
SET DIR("A")="Enter As of Date for 4 month period"
+3 DO ^DIR
KILL DIR
IF Y<1
GOTO PCP
SET APCLED=Y
SET APCLEDD=$$FMTE^XLFDT(APCLED)
+4 SET APCLBD=$$FMADD^XLFDT(APCLED,-(4*30.5))
+5 SET APCLSD=$$FMADD^XLFDT(APCLBD,-1)
+6 ;
+7 QUIT
ZIS ;call to XBDBQUE
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO EDATE
+3 SET XBRP="PRINT^APCLDR31"
SET XBRC="PROC^APCLDR3"
SET XBRX="EXIT^APCLDR3"
SET XBNS="APCL"
+4 DO ^XBDBQUE
+5 DO EXIT
+6 QUIT
EXIT ;clean up and exit
+1 KILL A,B,C,P,X,Y
+2 DO EN^XBVK("APCL")
+3 DO ^XBFMK
+4 DO KILL^AUPNPAT
+5 QUIT
+6 ;
PROC ;EP - called from XBDBQUE
+1 SET APCLJOB=$JOB
SET APCLBTH=$HOROLOG
+2 KILL ^XTMP("APCLDR3",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLDR3","DM LIST DM PATIENTS")
+4 DO REGPROC
+5 QUIT
REGPROC ;
+1 SET X=0
FOR
SET X=$ORDER(^ACM(41,"B",APCLREG,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF APCLSTAT]""
IF $PIECE($GET(^ACM(41,X,"DT")),U,1)=APCLSTAT
SET DFN=$PIECE(^ACM(41,X,0),U,2)
DO CHKSET
QUIT
+3 IF APCLSTAT=""
SET DFN=$PIECE(^ACM(41,X,0),U,2)
DO CHKSET
QUIT
+4 QUIT
End DoDot:1
+5 QUIT
CHKSET ;
+1 IF $$DOD^AUPNPAT(DFN)]""
QUIT
+2 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+3 ;I APCLPCP,$P(^AUPNPAT(DFN,0),U,14)'=APCLPCP Q
+4 SET P=$$VAL^XBDIQ1(9000001,DFN,.14)
SET P=$SELECT(P]"":P,1:"???")
+5 SET P1=$$VALI^XBDIQ1(9000001,DFN,.14)
+6 SET C=$$COMMRES^AUPNPAT(DFN,"E")
SET C=$SELECT(C]"":C,1:"???")
+7 SET ^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",P,C,$PIECE(^DPT(DFN,0),U),DFN)=$SELECT(P1:P1,1:"???")
+8 QUIT
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
DATE(B) ;
+1 IF $GET(B)=""
QUIT ""
+2 QUIT $EXTRACT(B,4,5)_"/"_$EXTRACT(B,6,7)_"/"_$EXTRACT(B,2,3)
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 ;----------
POST ;EP
+1 SET X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM PTS 4 MONTHS","DMV")
+2 IF 'X
WRITE "Attempt to add Patients w/selected values in 4 months option failed.."
HANG 3
+3 QUIT
SUBTOT ;EP
+1 IF 'APCLWR
QUIT
+2 SET APCLSUB=""
+3 IF $Y>(APCLIOSL-9)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
+4 WRITE !,"Subtotals for "_$EXTRACT(APCLP,1,16)_": ",?37,"# Patients",?50," # w/item done",?70,"%"
+5 WRITE !?2,"Last Clinic Visit",?38,$JUSTIFY($$C(APCLSTOT(0),0,8),9),?52,$JUSTIFY($$C($GET(APCLSTOT(1)),0,8),9)
+6 SET X=($GET(APCLSTOT(1))/APCLSTOT(0))*100
+7 WRITE ?67,$JUSTIFY(X,6,2)
+8 WRITE !?2,"Blood Pressure",?38,$JUSTIFY($$C(APCLSTOT(0),0,8),9),?52,$JUSTIFY($$C($GET(APCLSTOT(2)),0,8),9)
+9 SET X=($GET(APCLSTOT(2))/APCLSTOT(0))*100
+10 WRITE ?67,$JUSTIFY(X,6,2)
+11 WRITE !?2,"HGB A1C",?38,$JUSTIFY($$C(APCLSTOT(0),0,8),9),?52,$JUSTIFY($$C($GET(APCLSTOT(3)),0,8),9)
+12 SET X=($GET(APCLSTOT(3))/APCLSTOT(0))*100
+13 WRITE ?67,$JUSTIFY(X,6,2)
+14 WRITE !?2,"Total Cholesterol",?38,$JUSTIFY($$C(APCLSTOT(0),0,8),9),?52,$JUSTIFY($$C($GET(APCLSTOT(4)),0,8),9)
+15 SET X=($GET(APCLSTOT(4))/APCLSTOT(0))*100
+16 WRITE ?67,$JUSTIFY(X,6,2)
+17 WRITE !?2,"LDL Cholesterol",?38,$JUSTIFY($$C(APCLSTOT(0),0,8),9),?52,$JUSTIFY($$C($GET(APCLSTOT(5)),0,8),9)
+18 SET X=($GET(APCLSTOT(5))/APCLSTOT(0))*100
+19 WRITE ?67,$JUSTIFY(X,6,2)
+20 WRITE !?2,"HDL Cholesterol",?38,$JUSTIFY($$C(APCLSTOT(0),0,8),9),?52,$JUSTIFY($$C($GET(APCLSTOT(6)),0,8),9)
+21 SET X=($GET(APCLSTOT(6))/APCLSTOT(0))*100
+22 WRITE ?67,$JUSTIFY(X,6,2)
+23 KILL APCLSUB
+24 QUIT
FINH ;
+1 WRITE !,$$CTR("Value Totals/Comparisons for: "_APCLP,80),!
+2 WRITE !?35,"PROVIDER SPECIFIC",?56,"TOTAL REGISTER",!
+3 WRITE ?35,"# pats",?48,"%",?56,"# pats",?68,"%",!
+4 QUIT
FINTOT ;EP
+1 SET APCLFINL=""
+2 ;print page for each provider from APCLHGB, ETC
+3 SET APCLP=""
FOR
SET APCLP=$ORDER(APCLTHGB(APCLP))
IF APCLP=""!($DATA(APCLQ))
QUIT
Begin DoDot:1
+4 SET APCLP1=""
FOR
SET APCLP1=$ORDER(APCLTHGB(APCLP,APCLP1))
IF APCLP1=""
QUIT
DO FINTOT1
End DoDot:1
+5 QUIT
FINTOT1 ;
+1 IF APCLPCP
IF APCLP1'=APCLPCP
QUIT
+2 ;header, then print and calculate
+3 DO HEAD^APCLDR31
+4 IF $DATA(APCLQ)
QUIT
+5 DO FINH
+6 SET APCLTOTP=$PIECE(APCLTHGB,U)
SET APCLTOPP=$PIECE(APCLTHGB(APCLP,APCLP1),U)
+7 WRITE !,"Total Number of Patients",?33,$JUSTIFY($$C(APCLTOPP,0,8),9),?53,$JUSTIFY($$C(APCLTOTP,0,8),9),!
+8 WRITE !,"Blood Glucose Control"
+9 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+10 SET APCLPN=$PIECE(APCLTHGB(APCLP,APCLP1),U,2)
SET APCLTN=$PIECE(APCLTHGB,U,2)
WRITE !?2,"HbA1c <7.0"
DO W
+11 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+12 SET APCLPN=$PIECE(APCLTHGB(APCLP,APCLP1),U,3)
SET APCLTN=$PIECE(APCLTHGB,U,3)
WRITE !?8,"7.0-7.9"
DO W
+13 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+14 SET APCLPN=$PIECE(APCLTHGB(APCLP,APCLP1),U,4)
SET APCLTN=$PIECE(APCLTHGB,U,4)
WRITE !?8,"8.0-8.9"
DO W
+15 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+16 SET APCLPN=$PIECE(APCLTHGB(APCLP,APCLP1),U,5)
SET APCLTN=$PIECE(APCLTHGB,U,5)
WRITE !?8,"9.0-9.9"
DO W
+17 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+18 SET APCLPN=$PIECE(APCLTHGB(APCLP,APCLP1),U,6)
SET APCLTN=$PIECE(APCLTHGB,U,6)
WRITE !?8,"10.0-10.9"
DO W
+19 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+20 SET APCLPN=$PIECE(APCLTHGB(APCLP,APCLP1),U,7)
SET APCLTN=$PIECE(APCLTHGB,U,7)
WRITE !?8,"11.0 or higher"
DO W
+21 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+22 SET APCLPN=$PIECE(APCLTHGB(APCLP,APCLP1),U,8)
SET APCLTN=$PIECE(APCLTHGB,U,8)
WRITE !?8,"Tested but no value"
DO W
+23 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+24 SET APCLPN=$PIECE(APCLTHGB(APCLP,APCLP1),U,9)
SET APCLTN=$PIECE(APCLTHGB,U,9)
WRITE !?8,"Not tested in 4 months"
DO W
FINBP ;
+1 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+2 WRITE !!,"Blood Pressure Control"
+3 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+4 SET APCLPN=$PIECE(APCLTBP(APCLP,APCLP1),U,2)
SET APCLTN=$PIECE(APCLTBP,U,2)
WRITE !?8,"<120/80"
DO W
+5 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+6 SET APCLPN=$PIECE(APCLTBP(APCLP,APCLP1),U,3)
SET APCLTN=$PIECE(APCLTBP,U,3)
WRITE !?8,"120/80-<130/85"
DO W
+7 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+8 SET APCLPN=$PIECE(APCLTBP(APCLP,APCLP1),U,4)
SET APCLTN=$PIECE(APCLTBP,U,4)
WRITE !?8,"130/85-<140/90"
DO W
+9 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+10 SET APCLPN=$PIECE(APCLTBP(APCLP,APCLP1),U,5)
SET APCLTN=$PIECE(APCLTBP,U,5)
WRITE !?8,"140/90-<160/95"
DO W
+11 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+12 SET APCLPN=$PIECE(APCLTBP(APCLP,APCLP1),U,6)
SET APCLTN=$PIECE(APCLTBP,U,6)
WRITE !?8,"160/95 or higher"
DO W
+13 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+14 SET APCLPN=$PIECE(APCLTBP(APCLP,APCLP1),U,7)
SET APCLTN=$PIECE(APCLTBP,U,7)
WRITE !?8,"Not tested in 4 months"
DO W
FINLDL ;
+1 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+2 WRITE !!,"LDL Cholesterol"
+3 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+4 SET APCLPN=$PIECE(APCLTLDL(APCLP,APCLP1),U,2)
SET APCLTN=$PIECE(APCLTLDL,U,2)
WRITE !?8,"<100 mg/dl"
DO W
+5 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+6 SET APCLPN=$PIECE(APCLTLDL(APCLP,APCLP1),U,3)
SET APCLTN=$PIECE(APCLTLDL,U,3)
WRITE !?8,"100-129 mg/dl"
DO W
+7 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+8 SET APCLPN=$PIECE(APCLTLDL(APCLP,APCLP1),U,4)
SET APCLTN=$PIECE(APCLTLDL,U,4)
WRITE !?8,"130-160 mg/dl"
DO W
+9 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+10 SET APCLPN=$PIECE(APCLTLDL(APCLP,APCLP1),U,5)
SET APCLTN=$PIECE(APCLTLDL,U,5)
WRITE !?8,">160 mg/dl"
DO W
+11 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+12 SET APCLPN=$PIECE(APCLTLDL(APCLP,APCLP1),U,6)
SET APCLTN=$PIECE(APCLTLDL,U,6)
WRITE !?8,"Tested but no value"
DO W
+13 IF $Y>(APCLIOSL-4)
DO HEAD^APCLDR31
IF $DATA(APCLQ)
QUIT
DO FINH
+14 SET APCLPN=$PIECE(APCLTLDL(APCLP,APCLP1),U,7)
SET APCLTN=$PIECE(APCLTLDL,U,7)
WRITE !?8,"Not tested in 15 months"
DO W
+15 QUIT
W ;
+1 WRITE ?33,$JUSTIFY($$C(APCLPN,0,8),9),?45,$$PER(APCLPN,APCLTOPP),?53,$JUSTIFY($$C(APCLTN,0,8),9),?65,$$PER(APCLTN,APCLTOTP)
+2 QUIT
PER(N,D) ;n=numerator, d=denominator
+1 IF $GET(D)=""
QUIT ""
+2 IF $GET(D)=0
QUIT ""
+3 NEW X,Y,Z
+4 SET X=N/D
SET X=X*100
SET X=$JUSTIFY(X,5,1)
+5 QUIT X
+6 ;
TEST ;
+1 DO BDMG(1,"A",,DT,"ACTIVE")
+2 QUIT
BDMG(APCLREG,APCLSTAT,APCLPCP,APCLED,APCLSTAR) ;EP - GUI DMS Entry Point
+1 ;cmi/anch/maw added 10/19/2004
+2 SET APCLEDD=$$FMTE^XLFDT(APCLED)
+3 SET APCLGUI=1
+4 SET APCLBD=$$FMADD^XLFDT(APCLED,-(4*30.5))
+5 SET APCLSD=$$FMADD^XLFDT(APCLBD,-1)
+6 SET APCLPCP=$GET(APCLPCP)
+7 NEW APCLNOW,APCLOPT,APCLIEN
+8 SET APCLOPT="DM Register Patients and Select Values in 4 Months"
+9 DO NOW^%DTC
+10 SET APCLNOW=$GET(%)
+11 KILL DD,DO,DIC
+12 SET X=DUZ_APCLNOW
+13 SET DIC("DR")=".02////"_DUZ_";.03////"_APCLNOW_";.06///"_$GET(APCLOPT)_";.07////R"
+14 SET DIC="^APCLGUIR("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9001004.4
+15 DO FILE^DICN
+16 KILL DIADD,DLAYGO,DIC,DA
+17 IF Y=-1
SET APCLIEN=-1
QUIT
+18 SET APCLIEN=+Y
+19 ;cmi/maw added
SET BDMGIEN=APCLIEN
+20 DO ^XBFMK
+21 KILL ZTSAVE
SET ZTSAVE("*")=""
+22 ;D GUIEP for interactive testing
+23 SET ZTIO=""
SET ZTDTH=$$NOW^XLFDT
SET ZTRTN="GUIEP^APCLDR3"
SET ZTDESC="GUI DM 4 MONTHS"
DO ^%ZTLOAD
+24 DO EXIT
+25 QUIT
GUIEP ;EP
+1 DO PROC
+2 KILL ^TMP($JOB,"APCLDR3")
+3 SET IOM=80
+4 DO GUIR^XBLM("PRINT^APCLDR31","^TMP($J,""APCLDR3"",")
+5 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"APCLDR3",X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET APCLDATA=^TMP($JOB,"APCLDR3",X)
+7 IF APCLDATA="ZZZZZZZ"
SET APCLDATA=$CHAR(12)
+8 SET ^APCLGUIR(APCLIEN,11,X,0)=APCLDATA
SET C=C+1
End DoDot:1
+9 SET ^APCLGUIR(APCLIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+10 SET DA=APCLIEN
SET DIK="^APCLGUIR("
DO IX1^DIK
+11 DO ENDLOG
+12 KILL ^TMP($JOB,"APCLDR3")
+13 DO EXIT
+14 SET ZTREQ="@"
+15 QUIT
+16 ;
ENDLOG ;-- write the end of the log
+1 DO NOW^%DTC
+2 SET APCLNOW=$GET(%)
+3 SET DIE="^APCLGUIR("
SET DA=APCLIEN
SET DR=".04////"_APCLNOW_";.07////C"
+4 DO ^DIE
+5 KILL DIE,DR,DA
+6 QUIT
