- 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
