APCLDR31.m

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