APCLW6P ; IHS/CMI/LAB - print dx by age ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
START ;
S APCL80="",$P(APCL80,"-",80)="-"
S (APCLPG,APCLSEXP)=0
K APCLQUIT
D HEAD I '$D(^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS")) W !,"NO PATIENT DATA TO REPORT",! G DONE
S APCLMOVE="UP" D START1
I $D(APCLQUIT) D DONE Q
S APCLMOVE="DOWN" D START1
I $D(APCLQUIT) D DONE Q
W !!,"TOTAL NUMBER OF PATIENTS: ",APCLGRAN
DONE ;
K ^XTMP("APCLW6",APCLJ,APCLH),APCLJ,APCLH
D DONE^APCLOSUT
Q
START1 ;
S APCLAGE="" F S APCLAGE=$O(^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE)) Q:APCLAGE=""!($D(APCLQUIT)) D PAT
Q
PAT ;
S APCLNAME="" F S APCLNAME=$O(^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE,APCLNAME)) Q:APCLNAME=""!($D(APCLQUIT)) D
.S DFN=0 F S DFN=$O(^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE,APCLNAME,DFN)) Q:DFN'=+DFN!($D(APCLQUIT)) D
..S R=^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE,APCLNAME,DFN)
..I $Y>(IOSL-3) D HEAD Q:$D(APCLQUIT)
..W !!,$E(APCLNAME,1,30),?31,$$HRN^AUPNPAT(DFN,DUZ(2)),?38,APCLAGE,?42,$P(^DPT(DFN,0),U,2),?46,$E($$COMMRES^AUPNPAT(DFN),1,15),?63,$E($$TRIBE^AUPNPAT(DFN),1,15)
..W !?3,"HT: ",$J($P(R,U,3),5,1),?13,"HT DATE: ",$$DATE($P(R,U,4)),?32,"WT: ",$J($P(R,U,1),6,1),?45,"WT DATE: ",$$DATE($P(R,U,2)),?65,"BMI: ",$J($P(R,U,5),5,1)
..W !?3,"HT: ",$J($P(R,U,9),5,1),?13,"HT DATE: ",$$DATE($P(R,U,10)),?32,"WT: ",$J($P(R,U,7),6,1),?45,"WT DATE: ",$$DATE($P(R,U,8)),?65,"BMI: ",$J($P(R,U,11),5,1)
Q
HEAD 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 APCLQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF S APCLPG=APCLPG+1
W !
S X=$P(^DIC(4,DUZ(2),0),"^")
W !,$P(^VA(200,DUZ,0),"^",2),$$CTR(X,80),?71,"Page ",APCLPG,!
W !,"List of Patients moving from the normal to the "
W !,"NHANES 85th-94th Percentile or have moved from the NHANES 85th-94th"
W !,"Percentile to the NHANES >= 95th Percentile"
S APCLTEXT="Report includes: "_$S(APCLSEX="B":"MALES & FEMALES",APCLSEX="F":"FEMALES",APCLSEX="M":"MALES",1:"HUH") W !!,$$CTR(APCLTEXT,80)
I APCLTYPE="P" S X="Age Range: "_APCLLOWA_" - "_APCLHGHA W !,$$CTR(X,80)
I APCLSEAT'="" S APCLTEXT="Search Template of Patients: "_$P(^DIBT(APCLSEAT,0),U)
I APCLSEAT'="" S APCLLENG=$L(APCLTEXT) W !?(80-APCLLENG)/2,APCLTEXT
W !!,"PATIENT NAME",?31,"HRN #",?38,"AGE",?42,"M/F",?46,"COMMUNITY",?63,"TRIBE"
W !,APCL80
Q
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,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
APCLW6P ; IHS/CMI/LAB - print dx by age ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
START ;
+1 SET APCL80=""
SET $PIECE(APCL80,"-",80)="-"
+2 SET (APCLPG,APCLSEXP)=0
+3 KILL APCLQUIT
+4 DO HEAD
IF '$DATA(^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS"))
WRITE !,"NO PATIENT DATA TO REPORT",!
GOTO DONE
+5 SET APCLMOVE="UP"
DO START1
+6 IF $DATA(APCLQUIT)
DO DONE
QUIT
+7 SET APCLMOVE="DOWN"
DO START1
+8 IF $DATA(APCLQUIT)
DO DONE
QUIT
+9 WRITE !!,"TOTAL NUMBER OF PATIENTS: ",APCLGRAN
DONE ;
+1 KILL ^XTMP("APCLW6",APCLJ,APCLH),APCLJ,APCLH
+2 DO DONE^APCLOSUT
+3 QUIT
START1 ;
+1 SET APCLAGE=""
FOR
SET APCLAGE=$ORDER(^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE))
IF APCLAGE=""!($DATA(APCLQUIT))
QUIT
DO PAT
+2 QUIT
PAT ;
+1 SET APCLNAME=""
FOR
SET APCLNAME=$ORDER(^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE,APCLNAME))
IF APCLNAME=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+2 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE,APCLNAME,DFN))
IF DFN'=+DFN!($DATA(APCLQUIT))
QUIT
Begin DoDot:2
+3 SET R=^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE,APCLNAME,DFN)
+4 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+5 WRITE !!,$EXTRACT(APCLNAME,1,30),?31,$$HRN^AUPNPAT(DFN,DUZ(2)),?38,APCLAGE,?42,$PIECE(^DPT(DFN,0),U,2),?46,$EXTRACT($$COMMRES^AUPNPAT(DFN),1,15),?63,$EXTRACT($$TRIBE^AUPNPAT(DFN),1,15)
+6 WRITE !?3,"HT: ",$JUSTIFY($PIECE(R,U,3),5,1),?13,"HT DATE: ",$$DATE($PIECE(R,U,4)),?32,"WT: ",$JUSTIFY($PIECE(R,U,1),6,1),?45,"WT DATE: ",$$DATE($PIECE(R,U,2)),?65,"BMI: ",$JUSTIFY($PIECE(R,U,5),5,1)
+7 WRITE !?3,"HT: ",$JUSTIFY($PIECE(R,U,9),5,1),?13,"HT DATE: ",$$DATE($PIECE(R,U,10)),?32,"WT: ",$JUSTIFY($PIECE(R,U,7),6,1),?45,"WT DATE: ",$$DATE($PIECE(R,U,8)),?65,"BMI: ",$JUSTIFY($PIECE(R,U,11),5,1)
End DoDot:2
End DoDot:1
+8 QUIT
HEAD IF 'APCLPG
GOTO HEAD1
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 WRITE !
+3 SET X=$PIECE(^DIC(4,DUZ(2),0),"^")
+4 WRITE !,$PIECE(^VA(200,DUZ,0),"^",2),$$CTR(X,80),?71,"Page ",APCLPG,!
+5 WRITE !,"List of Patients moving from the normal to the "
+6 WRITE !,"NHANES 85th-94th Percentile or have moved from the NHANES 85th-94th"
+7 WRITE !,"Percentile to the NHANES >= 95th Percentile"
+8 SET APCLTEXT="Report includes: "_$SELECT(APCLSEX="B":"MALES & FEMALES",APCLSEX="F":"FEMALES",APCLSEX="M":"MALES",1:"HUH")
WRITE !!,$$CTR(APCLTEXT,80)
+9 IF APCLTYPE="P"
SET X="Age Range: "_APCLLOWA_" - "_APCLHGHA
WRITE !,$$CTR(X,80)
+10 IF APCLSEAT'=""
SET APCLTEXT="Search Template of Patients: "_$PIECE(^DIBT(APCLSEAT,0),U)
+11 IF APCLSEAT'=""
SET APCLLENG=$LENGTH(APCLTEXT)
WRITE !?(80-APCLLENG)/2,APCLTEXT
+12 WRITE !!,"PATIENT NAME",?31,"HRN #",?38,"AGE",?42,"M/F",?46,"COMMUNITY",?63,"TRIBE"
+13 WRITE !,APCL80
+14 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+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
