APCLDR31 ; IHS/CMI/LAB - patients dm list - chinle ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
PRINT ;EP - called from xbdbque
K APCLTHGB,APCLTBP,APCLTLDL,APCLFINL
S APCLIOSL=$S($G(APCLGUI):55,1:IOSL)
S APCLTHGB="",APCLTBP="",APCLTLDL=""
S APCLP=""
S APCL80D="-------------------------------------------------------------------------------"
S APCLPG=0
I '$D(^XTMP("APCLDR3",APCLJOB,APCLBTH)) D HEAD W !!,"NO PATIENTS TO REPORT" G DONE
S (APCLNAME,APCLP,APCLC)="" K APCLQ
F S APCLP=$O(^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP)) Q:APCLP=""!($D(APCLQ)) D
.;D HEAD Q:$D(APCLQ)
.S APCLCNT=0
.K APCLSTOT S APCLC="" F S APCLC=$O(^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP,APCLC)) Q:APCLC=""!($D(APCLQ)) D
..S APCLNAME="" F S APCLNAME=$O(^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP,APCLC,APCLNAME)) Q:APCLNAME=""!($D(APCLQ)) D
...S DFN="" F S DFN=$O(^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP,APCLC,APCLNAME,DFN)) Q:DFN'=+DFN!($D(APCLQ)) S APCLCNT=APCLCNT+1 D PRINT1
.Q:$D(APCLQ)
.D SUBTOT^APCLDR3
I $D(APCLQ) G DONE
D FINTOT^APCLDR3
D DONE
Q
PRINT1 ;
S APCLP1=^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP,APCLC,APCLNAME,DFN)
S APCLWR=1 I APCLPCP,APCLPCP'=APCLP1 S APCLWR=0
I '$D(APCLTHGB(APCLP,APCLP1)) S APCLTHGB(APCLP,APCLP1)=""
I '$D(APCLTBP(APCLP,APCLP1)) S APCLTBP(APCLP,APCLP1)=""
I '$D(APCLTLDL(APCLP,APCLP1)) S APCLTLDL(APCLP,APCLP1)=""
I APCLWR,APCLCNT=1 D HEAD Q:$D(APCLQ) I 1
E I APCLWR,$Y>(APCLIOSL-9) D HEAD Q:$D(APCLQ)
S APCLSTOT(0)=$G(APCLSTOT(0))+1
S APCLDOB=$$FMTE^XLFDT($P(^DPT(DFN,0),U,3))
W:APCLWR !,$E(APCLNAME,1,25),?27,$$HRN^AUPNPAT(DFN,DUZ(2)),?34,$$DOB^AUPNPAT(DFN,"E"),?47,APCLC
W:APCLWR !?2,"Test",?22,"In Past 4 Months",?50,"Next most recent"
W:APCLWR !?2,"----",?22,"----------------",?50,"----------------"
S (APCLDMV1,APCLDMV2)="" D LASTDMV
W:APCLWR !?2,"Last Clinic Visit"
I APCLDMV1>APCLSD W:APCLWR ?22,$$DATE(APCLDMV1),?50,$$DATE(APCLDMV2) S APCLSTOT(1)=$G(APCLSTOT(1))+1 I 1
E W:APCLWR ?50,$$DATE(APCLDMV1)
W:APCLWR !?2,"Blood Pressure (BP)"
S (APCLDMV1,APCLDMV2)="" D LASTBP
I $P(APCLDMV1,U)>APCLSD W:APCLWR ?22,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2),?50,$$DATE($P(APCLDMV2,U))_" "_$P(APCLDMV2,U,2) S APCLSTOT(2)=$G(APCLSTOT(2))+1 I 1
E W:APCLWR ?50,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2)
D BPS
HGB ;
W:APCLWR !?2,"Hgb A1C"
S (APCLDMV1,APCLDMV2)="" D LASTHBG
I $P(APCLDMV1,U)>APCLSD W:APCLWR ?22,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2),?50,$$DATE($P(APCLDMV2,U))_" "_$P(APCLDMV2,U,2) S APCLSTOT(3)=$G(APCLSTOT(3))+1 I 1
E W:APCLWR ?50,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2)
D HGBS
TC ;
W:APCLWR !?2,"Total Cholesterol"
S (APCLDMV1,APCLDMV2)="" D LASTTC
I $P(APCLDMV1,U)>APCLSD W:APCLWR ?22,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2),?50,$$DATE($P(APCLDMV2,U))_" "_$P(APCLDMV2,U,2) S APCLSTOT(4)=$G(APCLSTOT(4))+1 I 1
E W:APCLWR ?50,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2)
LDL ;
W:APCLWR !?2,"LDL Cholesterol"
S (APCLDMV1,APCLDMV2)="" D LASTLDL
I $P(APCLDMV1,U)>APCLSD W:APCLWR ?22,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2),?50,$$DATE($P(APCLDMV2,U))_" "_$P(APCLDMV2,U,2) S APCLSTOT(5)=$G(APCLSTOT(5))+1 I 1
E W:APCLWR ?50,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2)
D LDLS
HDL ;
W:APCLWR !?2,"HDL Cholesterol"
S (APCLDMV1,APCLDMV2)="" D LASTHDL
I $P(APCLDMV1,U)>APCLSD W:APCLWR ?22,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2),?50,$$DATE($P(APCLDMV2,U))_" "_$P(APCLDMV2,U,2) S APCLSTOT(6)=$G(APCLSTOT(6))+1 I 1
E W:APCLWR ?50,$$DATE($P(APCLDMV1,U))_" "_$P(APCLDMV1,U,2)
W:APCLWR !
Q
DONE ;
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
W:$D(IOF) @IOF
K ^XTMP("APCLDR3",APCLJOB,APCLBTH),APCLJOB,APCLBTH
Q
HEAD ;EP
I 'APCLPG G HEAD1
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
HEAD1 ;
W:$D(IOF) @IOF S APCLPG=APCLPG+1
I $G(APCLGUI),APCLPG'=1 W !,"ZZZZZZZ"
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!
W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
S X="Patients on the "_$P(^ACM(41.1,APCLREG,0),U)_" Register Status: "_$S($G(APCLSTAR)]"":APCLSTAR,1:"ALL") W $$CTR(X,80),!
W $$CTR("As of Date: "_APCLEDD_$S($D(APCLFINL):"",1:" Designated Provider: "_$G(APCLP)),80),!
Q:$D(APCLFINL)
PIH I '$D(APCLSUB) W !,"PATIENT NAME",?27,"HRN",?34,"DOB",?47,"COMMUNITY",?62,!,APCL80D
I $D(APCLSUB) W !,APCL80D
Q
LASTDMV ;EP - get last 2 dm clinic visits
NEW V,D,C
S C=0,D=0,V=0 F S D=$O(^AUPNVSIT("AA",DFN,D)) Q:D'=+D!(C=2) D
.S V=0 F S V=$O(^AUPNVSIT("AA",DFN,D,V)) Q:V'=+V!(C=2) D
..Q:$P(^AUPNVSIT(V,0),U,11)
..Q:'$P(^AUPNVSIT(V,0),U,9)
..Q:'$D(^AUPNVPOV("AD",V))
..Q:'$D(^AUPNVPRV("AD",V))
..Q:"TCE"[$P(^AUPNVSIT(V,0),U,7)
..S C=C+1 S:C=1 APCLDMV1=9999999-$P(D,".") S:C=2 APCLDMV2=9999999-$P(D,".")
..Q
.Q
Q
LASTBP ;PEP - return last wt
NEW %,E,W,A
K A
S %=DFN_"^LAST 2 MEAS BP;DURING "_APCLDOB_"-"_APCLEDD NEW X S E=$$START1^APCLDF(%,"A(")
S APCLDMV1=$P($G(A(1)),U)_"^"_$P($G(A(1)),U,2)
S APCLDMV2=$P($G(A(2)),U)_"^"_$P($G(A(2)),U,2)
Q
BPS ;
S $P(APCLTBP,U)=$P(APCLTBP,U)+1 ;total number of patients
S $P(APCLTBP(APCLP,APCLP1),U)=$P(APCLTBP(APCLP,APCLP1),U)+1
I $P(APCLDMV1,U)<APCLBD D Q
.S $P(APCLTBP,U,7)=$P(APCLTBP,U,7)+1 ;no value/not tested
.S $P(APCLTBP(APCLP,APCLP1),U,7)=$P(APCLTBP(APCLP,APCLP1),U,7)+1
.Q
S V=$P(APCLDMV1,U,2),S=$P(V,"/"),D=$P(V,"/",2)
I S=""!(D="") S $P(APCLTBP,U,7)=$P(APCLTBP,U,7)+1,$P(APCLTBP(APCLP,APCLP1),U,7)=$P(APCLTBP(APCLP,APCLP1),U,7)+1 Q
I S<120&(D<80) S $P(APCLTBP,U,2)=$P(APCLTBP,U,2)+1,$P(APCLTBP(APCLP,APCLP1),U,2)=$P(APCLTBP(APCLP,APCLP1),U,2)+1 Q
I S<130&(D<85) S $P(APCLTBP,U,3)=$P(APCLTBP,U,3)+1,$P(APCLTBP(APCLP,APCLP1),U,3)=$P(APCLTBP(APCLP,APCLP1),U,3)+1 Q
I S<140&(D<90) S $P(APCLTBP,U,4)=$P(APCLTBP,U,4)+1,$P(APCLTBP(APCLP,APCLP1),U,4)=$P(APCLTBP(APCLP,APCLP1),U,4)+1 Q
I S<160&(D<95) S $P(APCLTBP,U,5)=$P(APCLTBP,U,5)+1,$P(APCLTBP(APCLP,APCLP1),U,5)=$P(APCLTBP(APCLP,APCLP1),U,5)+1 Q
S $P(APCLTBP,U,6)=$P(APCLTBP,U,6)+1,$P(APCLTBP(APCLP,APCLP1),U,6)=$P(APCLTBP(APCLP,APCLP1),U,6)+1
Q
LDLS ;
S APCL15M=$$FMADD^XLFDT(APCLED,-(15*30))
S $P(APCLTLDL,U)=$P(APCLTLDL,U)+1 ;total number of patients
S $P(APCLTLDL(APCLP,APCLP1),U)=$P(APCLTLDL(APCLP,APCLP1),U)+1
I $P(APCLDMV1,U)'<APCL15M S V=$P(APCLDMV1,U,2) D LDLS1 Q
I $P(APCLDMV2,U)'<APCL15M S V=$P(APCLDMV2,U,2) D LDLS1 Q
S $P(APCLTLDL,U,7)=$P(APCLTLDL,U,7)+1,$P(APCLTLDL(APCLP,APCLP1),U,7)=$P(APCLTLDL(APCLP,APCLP1),U,7)+1
Q
LDLS1 ;
I V="" S $P(APCLTLDL,U,6)=$P(APCLTLDL,U,6)+1,$P(APCLTLDL(APCLP,APCLP1),U,6)=$P(APCLTLDL(APCLP,APCLP1),U,6)+1 Q
I $E(V)'=+$E(V) S $P(APCLTLDL,U,6)=$P(APCLTLDL,U,6)+1,$P(APCLTLDL(APCLP,APCLP1),U,6)=$P(APCLTLDL(APCLP,APCLP1),U,6)+1 Q
I V<100 S $P(APCLTLDL,U,2)=$P(APCLTLDL,U,2)+1,$P(APCLTLDL(APCLP,APCLP1),U,2)=$P(APCLTLDL(APCLP,APCLP1),U,2)+1 Q
I V<130&(V>99) S $P(APCLTLDL,U,3)=$P(APCLTLDL,U,3)+1,$P(APCLTLDL(APCLP,APCLP1),U,3)=$P(APCLTLDL(APCLP,APCLP1),U,3)+1 Q
I V>129&(V<161) S $P(APCLTLDL,U,4)=$P(APCLTLDL,U,4)+1,$P(APCLTLDL(APCLP,APCLP1),U,4)=$P(APCLTLDL(APCLP,APCLP1),U,4)+1 Q
I V>160 S $P(APCLTLDL,U,5)=$P(APCLTLDL,U,5)+1,$P(APCLTLDL(APCLP,APCLP1),U,5)=$P(APCLTLDL(APCLP,APCLP1),U,5)+1 Q
Q
HGBS ;subtotal hbg values
S $P(APCLTHGB,U)=$P(APCLTHGB,U)+1 ;total number of patients
S $P(APCLTHGB(APCLP,APCLP1),U)=$P(APCLTHGB(APCLP,APCLP1),U)+1
I $P(APCLDMV1,U)<APCLBD D Q
.S $P(APCLTHGB,U,9)=$P(APCLTHGB,U,9)+1 ;no value/not tested
.S $P(APCLTHGB(APCLP,APCLP1),U,9)=$P(APCLTHGB(APCLP,APCLP1),U,9)+1
.Q
S V=$P(APCLDMV1,U,2)
S P=$S(V="":8,V[">":7,$E(V)'=+$E(V):8,V<7.0:2,V>6.9&(V<8.0):3,V>7.9&(V<9.0):4,V>8.9&(V<10.0):5,V<11.0&(V>9.9):6,V>10.9:7,1:8)
S $P(APCLTHGB,U,P)=$P(APCLTHGB,U,P)+1
S $P(APCLTHGB(APCLP,APCLP1),U,P)=$P(APCLTHGB(APCLP,APCLP1),U,P)+1
Q
LASTHBG ;
NEW %,E,W,A
K A
S %=DFN_"^LAST 2 LAB [DM AUDIT HGB A1C;DURING "_APCLDOB_"-"_APCLEDD NEW X S E=$$START1^APCLDF(%,"A(")
S APCLDMV1=$P($G(A(1)),U)_"^"_$P($G(A(1)),U,2)_"^"_$P($G(A(1)),U,4)
S APCLDMV2=$P($G(A(2)),U)_"^"_$P($G(A(2)),U,2)
Q
LASTTC ;
NEW %,E,W,A
K A
S %=DFN_"^LAST 2 LAB [DM AUDIT CHOLESTEROL TAX;DURING "_APCLDOB_"-"_APCLEDD NEW X S E=$$START1^APCLDF(%,"A(")
S APCLDMV1=$P($G(A(1)),U)_"^"_$P($G(A(1)),U,2)
S APCLDMV2=$P($G(A(2)),U)_"^"_$P($G(A(2)),U,2)
Q
LASTLDL ;
NEW %,E,W,A
K A
S %=DFN_"^LAST 2 LAB [DM AUDIT LDL CHOLESTEROL TAX;DURING "_APCLDOB_"-"_APCLEDD NEW X S E=$$START1^APCLDF(%,"A(")
S APCLDMV1=$P($G(A(1)),U)_"^"_$P($G(A(1)),U,2)
S APCLDMV2=$P($G(A(2)),U)_"^"_$P($G(A(2)),U,2)
Q
LASTHDL ;
NEW %,E,W,A
K A
S %=DFN_"^LAST 2 LAB [DM AUDIT HDL TAX;DURING "_APCLDOB_"-"_APCLEDD NEW X S E=$$START1^APCLDF(%,"A(")
S APCLDMV1=$P($G(A(1)),U)_"^"_$P($G(A(1)),U,2)
S APCLDMV2=$P($G(A(2)),U)_"^"_$P($G(A(2)),U,2)
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")
;----------
APCLDR31 ; IHS/CMI/LAB - patients dm list - chinle ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
PRINT ;EP - called from xbdbque
+1 KILL APCLTHGB,APCLTBP,APCLTLDL,APCLFINL
+2 SET APCLIOSL=$SELECT($GET(APCLGUI):55,1:IOSL)
+3 SET APCLTHGB=""
SET APCLTBP=""
SET APCLTLDL=""
+4 SET APCLP=""
+5 SET APCL80D="-------------------------------------------------------------------------------"
+6 SET APCLPG=0
+7 IF '$DATA(^XTMP("APCLDR3",APCLJOB,APCLBTH))
DO HEAD
WRITE !!,"NO PATIENTS TO REPORT"
GOTO DONE
+8 SET (APCLNAME,APCLP,APCLC)=""
KILL APCLQ
+9 FOR
SET APCLP=$ORDER(^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP))
IF APCLP=""!($DATA(APCLQ))
QUIT
Begin DoDot:1
+10 ;D HEAD Q:$D(APCLQ)
+11 SET APCLCNT=0
+12 KILL APCLSTOT
SET APCLC=""
FOR
SET APCLC=$ORDER(^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP,APCLC))
IF APCLC=""!($DATA(APCLQ))
QUIT
Begin DoDot:2
+13 SET APCLNAME=""
FOR
SET APCLNAME=$ORDER(^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP,APCLC,APCLNAME))
IF APCLNAME=""!($DATA(APCLQ))
QUIT
Begin DoDot:3
+14 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP,APCLC,APCLNAME,DFN))
IF DFN'=+DFN!($DATA(APCLQ))
QUIT
SET APCLCNT=APCLCNT+1
DO PRINT1
End DoDot:3
End DoDot:2
+15 IF $DATA(APCLQ)
QUIT
+16 DO SUBTOT^APCLDR3
End DoDot:1
+17 IF $DATA(APCLQ)
GOTO DONE
+18 DO FINTOT^APCLDR3
+19 DO DONE
+20 QUIT
PRINT1 ;
+1 SET APCLP1=^XTMP("APCLDR3",APCLJOB,APCLBTH,"PATIENTS",APCLP,APCLC,APCLNAME,DFN)
+2 SET APCLWR=1
IF APCLPCP
IF APCLPCP'=APCLP1
SET APCLWR=0
+3 IF '$DATA(APCLTHGB(APCLP,APCLP1))
SET APCLTHGB(APCLP,APCLP1)=""
+4 IF '$DATA(APCLTBP(APCLP,APCLP1))
SET APCLTBP(APCLP,APCLP1)=""
+5 IF '$DATA(APCLTLDL(APCLP,APCLP1))
SET APCLTLDL(APCLP,APCLP1)=""
+6 IF APCLWR
IF APCLCNT=1
DO HEAD
IF $DATA(APCLQ)
QUIT
IF 1
+7 IF '$TEST
IF APCLWR
IF $Y>(APCLIOSL-9)
DO HEAD
IF $DATA(APCLQ)
QUIT
+8 SET APCLSTOT(0)=$GET(APCLSTOT(0))+1
+9 SET APCLDOB=$$FMTE^XLFDT($PIECE(^DPT(DFN,0),U,3))
+10 IF APCLWR
WRITE !,$EXTRACT(APCLNAME,1,25),?27,$$HRN^AUPNPAT(DFN,DUZ(2)),?34,$$DOB^AUPNPAT(DFN,"E"),?47,APCLC
+11 IF APCLWR
WRITE !?2,"Test",?22,"In Past 4 Months",?50,"Next most recent"
+12 IF APCLWR
WRITE !?2,"----",?22,"----------------",?50,"----------------"
+13 SET (APCLDMV1,APCLDMV2)=""
DO LASTDMV
+14 IF APCLWR
WRITE !?2,"Last Clinic Visit"
+15 IF APCLDMV1>APCLSD
IF APCLWR
WRITE ?22,$$DATE(APCLDMV1),?50,$$DATE(APCLDMV2)
SET APCLSTOT(1)=$GET(APCLSTOT(1))+1
IF 1
+16 IF '$TEST
IF APCLWR
WRITE ?50,$$DATE(APCLDMV1)
+17 IF APCLWR
WRITE !?2,"Blood Pressure (BP)"
+18 SET (APCLDMV1,APCLDMV2)=""
DO LASTBP
+19 IF $PIECE(APCLDMV1,U)>APCLSD
IF APCLWR
WRITE ?22,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2),?50,$$DATE($PIECE(APCLDMV2,U))_" "_$PIECE(APCLDMV2,U,2)
SET APCLSTOT(2)=$GET(APCLSTOT(2))+1
IF 1
+20 IF '$TEST
IF APCLWR
WRITE ?50,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2)
+21 DO BPS
HGB ;
+1 IF APCLWR
WRITE !?2,"Hgb A1C"
+2 SET (APCLDMV1,APCLDMV2)=""
DO LASTHBG
+3 IF $PIECE(APCLDMV1,U)>APCLSD
IF APCLWR
WRITE ?22,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2),?50,$$DATE($PIECE(APCLDMV2,U))_" "_$PIECE(APCLDMV2,U,2)
SET APCLSTOT(3)=$GET(APCLSTOT(3))+1
IF 1
+4 IF '$TEST
IF APCLWR
WRITE ?50,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2)
+5 DO HGBS
TC ;
+1 IF APCLWR
WRITE !?2,"Total Cholesterol"
+2 SET (APCLDMV1,APCLDMV2)=""
DO LASTTC
+3 IF $PIECE(APCLDMV1,U)>APCLSD
IF APCLWR
WRITE ?22,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2),?50,$$DATE($PIECE(APCLDMV2,U))_" "_$PIECE(APCLDMV2,U,2)
SET APCLSTOT(4)=$GET(APCLSTOT(4))+1
IF 1
+4 IF '$TEST
IF APCLWR
WRITE ?50,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2)
LDL ;
+1 IF APCLWR
WRITE !?2,"LDL Cholesterol"
+2 SET (APCLDMV1,APCLDMV2)=""
DO LASTLDL
+3 IF $PIECE(APCLDMV1,U)>APCLSD
IF APCLWR
WRITE ?22,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2),?50,$$DATE($PIECE(APCLDMV2,U))_" "_$PIECE(APCLDMV2,U,2)
SET APCLSTOT(5)=$GET(APCLSTOT(5))+1
IF 1
+4 IF '$TEST
IF APCLWR
WRITE ?50,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2)
+5 DO LDLS
HDL ;
+1 IF APCLWR
WRITE !?2,"HDL Cholesterol"
+2 SET (APCLDMV1,APCLDMV2)=""
DO LASTHDL
+3 IF $PIECE(APCLDMV1,U)>APCLSD
IF APCLWR
WRITE ?22,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2),?50,$$DATE($PIECE(APCLDMV2,U))_" "_$PIECE(APCLDMV2,U,2)
SET APCLSTOT(6)=$GET(APCLSTOT(6))+1
IF 1
+4 IF '$TEST
IF APCLWR
WRITE ?50,$$DATE($PIECE(APCLDMV1,U))_" "_$PIECE(APCLDMV1,U,2)
+5 IF APCLWR
WRITE !
+6 QUIT
DONE ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of report. HIT RETURN"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(IOF)
WRITE @IOF
+3 KILL ^XTMP("APCLDR3",APCLJOB,APCLBTH),APCLJOB,APCLBTH
+4 QUIT
HEAD ;EP
+1 IF 'APCLPG
GOTO HEAD1
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQ=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 IF $GET(APCLGUI)
IF APCLPG'=1
WRITE !,"ZZZZZZZ"
+3 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+4 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!
+5 WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!
+6 SET X="Patients on the "_$PIECE(^ACM(41.1,APCLREG,0),U)_" Register Status: "_$SELECT($GET(APCLSTAR)]"":APCLSTAR,1:"ALL")
WRITE $$CTR(X,80),!
+7 WRITE $$CTR("As of Date: "_APCLEDD_$SELECT($DATA(APCLFINL):"",1:" Designated Provider: "_$GET(APCLP)),80),!
+8 IF $DATA(APCLFINL)
QUIT
PIH IF '$DATA(APCLSUB)
WRITE !,"PATIENT NAME",?27,"HRN",?34,"DOB",?47,"COMMUNITY",?62,!,APCL80D
+1 IF $DATA(APCLSUB)
WRITE !,APCL80D
+2 QUIT
LASTDMV ;EP - get last 2 dm clinic visits
+1 NEW V,D,C
+2 SET C=0
SET D=0
SET V=0
FOR
SET D=$ORDER(^AUPNVSIT("AA",DFN,D))
IF D'=+D!(C=2)
QUIT
Begin DoDot:1
+3 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",DFN,D,V))
IF V'=+V!(C=2)
QUIT
Begin DoDot:2
+4 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+5 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+6 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+7 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+8 IF "TCE"[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+9 SET C=C+1
IF C=1
SET APCLDMV1=9999999-$PIECE(D,".")
IF C=2
SET APCLDMV2=9999999-$PIECE(D,".")
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
LASTBP ;PEP - return last wt
+1 NEW %,E,W,A
+2 KILL A
+3 SET %=DFN_"^LAST 2 MEAS BP;DURING "_APCLDOB_"-"_APCLEDD
NEW X
SET E=$$START1^APCLDF(%,"A(")
+4 SET APCLDMV1=$PIECE($GET(A(1)),U)_"^"_$PIECE($GET(A(1)),U,2)
+5 SET APCLDMV2=$PIECE($GET(A(2)),U)_"^"_$PIECE($GET(A(2)),U,2)
+6 QUIT
BPS ;
+1 ;total number of patients
SET $PIECE(APCLTBP,U)=$PIECE(APCLTBP,U)+1
+2 SET $PIECE(APCLTBP(APCLP,APCLP1),U)=$PIECE(APCLTBP(APCLP,APCLP1),U)+1
+3 IF $PIECE(APCLDMV1,U)<APCLBD
Begin DoDot:1
+4 ;no value/not tested
SET $PIECE(APCLTBP,U,7)=$PIECE(APCLTBP,U,7)+1
+5 SET $PIECE(APCLTBP(APCLP,APCLP1),U,7)=$PIECE(APCLTBP(APCLP,APCLP1),U,7)+1
+6 QUIT
End DoDot:1
QUIT
+7 SET V=$PIECE(APCLDMV1,U,2)
SET S=$PIECE(V,"/")
SET D=$PIECE(V,"/",2)
+8 IF S=""!(D="")
SET $PIECE(APCLTBP,U,7)=$PIECE(APCLTBP,U,7)+1
SET $PIECE(APCLTBP(APCLP,APCLP1),U,7)=$PIECE(APCLTBP(APCLP,APCLP1),U,7)+1
QUIT
+9 IF S<120&(D<80)
SET $PIECE(APCLTBP,U,2)=$PIECE(APCLTBP,U,2)+1
SET $PIECE(APCLTBP(APCLP,APCLP1),U,2)=$PIECE(APCLTBP(APCLP,APCLP1),U,2)+1
QUIT
+10 IF S<130&(D<85)
SET $PIECE(APCLTBP,U,3)=$PIECE(APCLTBP,U,3)+1
SET $PIECE(APCLTBP(APCLP,APCLP1),U,3)=$PIECE(APCLTBP(APCLP,APCLP1),U,3)+1
QUIT
+11 IF S<140&(D<90)
SET $PIECE(APCLTBP,U,4)=$PIECE(APCLTBP,U,4)+1
SET $PIECE(APCLTBP(APCLP,APCLP1),U,4)=$PIECE(APCLTBP(APCLP,APCLP1),U,4)+1
QUIT
+12 IF S<160&(D<95)
SET $PIECE(APCLTBP,U,5)=$PIECE(APCLTBP,U,5)+1
SET $PIECE(APCLTBP(APCLP,APCLP1),U,5)=$PIECE(APCLTBP(APCLP,APCLP1),U,5)+1
QUIT
+13 SET $PIECE(APCLTBP,U,6)=$PIECE(APCLTBP,U,6)+1
SET $PIECE(APCLTBP(APCLP,APCLP1),U,6)=$PIECE(APCLTBP(APCLP,APCLP1),U,6)+1
+14 QUIT
LDLS ;
+1 SET APCL15M=$$FMADD^XLFDT(APCLED,-(15*30))
+2 ;total number of patients
SET $PIECE(APCLTLDL,U)=$PIECE(APCLTLDL,U)+1
+3 SET $PIECE(APCLTLDL(APCLP,APCLP1),U)=$PIECE(APCLTLDL(APCLP,APCLP1),U)+1
+4 IF $PIECE(APCLDMV1,U)'<APCL15M
SET V=$PIECE(APCLDMV1,U,2)
DO LDLS1
QUIT
+5 IF $PIECE(APCLDMV2,U)'<APCL15M
SET V=$PIECE(APCLDMV2,U,2)
DO LDLS1
QUIT
+6 SET $PIECE(APCLTLDL,U,7)=$PIECE(APCLTLDL,U,7)+1
SET $PIECE(APCLTLDL(APCLP,APCLP1),U,7)=$PIECE(APCLTLDL(APCLP,APCLP1),U,7)+1
+7 QUIT
LDLS1 ;
+1 IF V=""
SET $PIECE(APCLTLDL,U,6)=$PIECE(APCLTLDL,U,6)+1
SET $PIECE(APCLTLDL(APCLP,APCLP1),U,6)=$PIECE(APCLTLDL(APCLP,APCLP1),U,6)+1
QUIT
+2 IF $EXTRACT(V)'=+$EXTRACT(V)
SET $PIECE(APCLTLDL,U,6)=$PIECE(APCLTLDL,U,6)+1
SET $PIECE(APCLTLDL(APCLP,APCLP1),U,6)=$PIECE(APCLTLDL(APCLP,APCLP1),U,6)+1
QUIT
+3 IF V<100
SET $PIECE(APCLTLDL,U,2)=$PIECE(APCLTLDL,U,2)+1
SET $PIECE(APCLTLDL(APCLP,APCLP1),U,2)=$PIECE(APCLTLDL(APCLP,APCLP1),U,2)+1
QUIT
+4 IF V<130&(V>99)
SET $PIECE(APCLTLDL,U,3)=$PIECE(APCLTLDL,U,3)+1
SET $PIECE(APCLTLDL(APCLP,APCLP1),U,3)=$PIECE(APCLTLDL(APCLP,APCLP1),U,3)+1
QUIT
+5 IF V>129&(V<161)
SET $PIECE(APCLTLDL,U,4)=$PIECE(APCLTLDL,U,4)+1
SET $PIECE(APCLTLDL(APCLP,APCLP1),U,4)=$PIECE(APCLTLDL(APCLP,APCLP1),U,4)+1
QUIT
+6 IF V>160
SET $PIECE(APCLTLDL,U,5)=$PIECE(APCLTLDL,U,5)+1
SET $PIECE(APCLTLDL(APCLP,APCLP1),U,5)=$PIECE(APCLTLDL(APCLP,APCLP1),U,5)+1
QUIT
+7 QUIT
HGBS ;subtotal hbg values
+1 ;total number of patients
SET $PIECE(APCLTHGB,U)=$PIECE(APCLTHGB,U)+1
+2 SET $PIECE(APCLTHGB(APCLP,APCLP1),U)=$PIECE(APCLTHGB(APCLP,APCLP1),U)+1
+3 IF $PIECE(APCLDMV1,U)<APCLBD
Begin DoDot:1
+4 ;no value/not tested
SET $PIECE(APCLTHGB,U,9)=$PIECE(APCLTHGB,U,9)+1
+5 SET $PIECE(APCLTHGB(APCLP,APCLP1),U,9)=$PIECE(APCLTHGB(APCLP,APCLP1),U,9)+1
+6 QUIT
End DoDot:1
QUIT
+7 SET V=$PIECE(APCLDMV1,U,2)
+8 SET P=$SELECT(V="":8,V[">":7,$EXTRACT(V)'=+$EXTRACT(V):8,V<7.0:2,V>6.9&(V<8.0):3,V>7.9&(V<9.0):4,V>8.9&(V<10.0):5,V<11.0&(V>9.9):6,V>10.9:7,1:8)
+9 SET $PIECE(APCLTHGB,U,P)=$PIECE(APCLTHGB,U,P)+1
+10 SET $PIECE(APCLTHGB(APCLP,APCLP1),U,P)=$PIECE(APCLTHGB(APCLP,APCLP1),U,P)+1
+11 QUIT
LASTHBG ;
+1 NEW %,E,W,A
+2 KILL A
+3 SET %=DFN_"^LAST 2 LAB [DM AUDIT HGB A1C;DURING "_APCLDOB_"-"_APCLEDD
NEW X
SET E=$$START1^APCLDF(%,"A(")
+4 SET APCLDMV1=$PIECE($GET(A(1)),U)_"^"_$PIECE($GET(A(1)),U,2)_"^"_$PIECE($GET(A(1)),U,4)
+5 SET APCLDMV2=$PIECE($GET(A(2)),U)_"^"_$PIECE($GET(A(2)),U,2)
+6 QUIT
LASTTC ;
+1 NEW %,E,W,A
+2 KILL A
+3 SET %=DFN_"^LAST 2 LAB [DM AUDIT CHOLESTEROL TAX;DURING "_APCLDOB_"-"_APCLEDD
NEW X
SET E=$$START1^APCLDF(%,"A(")
+4 SET APCLDMV1=$PIECE($GET(A(1)),U)_"^"_$PIECE($GET(A(1)),U,2)
+5 SET APCLDMV2=$PIECE($GET(A(2)),U)_"^"_$PIECE($GET(A(2)),U,2)
+6 QUIT
LASTLDL ;
+1 NEW %,E,W,A
+2 KILL A
+3 SET %=DFN_"^LAST 2 LAB [DM AUDIT LDL CHOLESTEROL TAX;DURING "_APCLDOB_"-"_APCLEDD
NEW X
SET E=$$START1^APCLDF(%,"A(")
+4 SET APCLDMV1=$PIECE($GET(A(1)),U)_"^"_$PIECE($GET(A(1)),U,2)
+5 SET APCLDMV2=$PIECE($GET(A(2)),U)_"^"_$PIECE($GET(A(2)),U,2)
+6 QUIT
LASTHDL ;
+1 NEW %,E,W,A
+2 KILL A
+3 SET %=DFN_"^LAST 2 LAB [DM AUDIT HDL TAX;DURING "_APCLDOB_"-"_APCLEDD
NEW X
SET E=$$START1^APCLDF(%,"A(")
+4 SET APCLDMV1=$PIECE($GET(A(1)),U)_"^"_$PIECE($GET(A(1)),U,2)
+5 SET APCLDMV2=$PIECE($GET(A(2)),U)_"^"_$PIECE($GET(A(2)),U,2)
+6 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 ;----------
