BCHRC5P ; IHS/CMI/LAB - print dx by age ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - tmp to xtmp
START ;
S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y
S Y=DT D DD^%DT S BCHDT=Y
;S BCHPG=0 D HEAD
S BCHPG=0
K BCHQUIT
I '$D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA")) W !!,"NO DATA TO REPORT" G DONE
HA ;
D @("HEAD"_(2-($E(IOST,1,2)="C-"))) ; LAB
;
I $Y>(IOSL-4) D HEAD G:$D(BCHQUIT) DONE
;S BCHTM=8888,BCHTF=7777
W !,"TOTAL",?8,$J(BCHTM,5),?14,$J(BCHTF,5)
S BCHX=0,J=20 F S BCHX=$O(^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHX)) Q:BCHX'=+BCHX!($D(BCHQUIT)) D
.S M=^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHX,"M"),F=^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHX,"F")
.;S M=2222,F=3333
.W ?J,$J(M,5) S J=J+6 W ?J,$J(F,5) S J=J+6
.Q
S BCHX=0 F S BCHX=$O(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX)) Q:BCHX'=+BCHX!($D(BCHQUIT)) D
.I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT)
.W !?2,$P(^BCHTPROB(BCHX,0),U,2) ;," ",$E($P(^BCHTPROB(BCHX,0),U),1,5)
.S M=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,"TOTAL","M")):^("M"),1:0),F=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,"TOTAL","F")):^("F"),1:0) W ?8,$J(M,5),?14,$J(F,5)
.S J=20 F I=1:1:$L(BCHRBIN,";") S M=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,I,"M")):^("M"),1:"."),F=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,I,"F")):^("F"),1:".") W ?J,$J(M,5) S J=J+6 W ?J,$J(F,5) S J=J+6
;
DONE D DONE^BCHUTIL1
K ^XTMP("BCHRC5",BCHJOB,BCHBT),BCHJOB,BCHBT,BCHX
Q
HEAD ;
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q
HEAD1 ; if terminal
W:$D(IOF) @IOF
HEAD2 ; if printer
S BCHPG=BCHPG+1
W !,$P(^VA(200,DUZ,0),U,2),?30,"DATE GENERATED: ",BCHDT,?70,"Page ",BCHPG,!
W $$CTR^BCHRLU($$LOC^BCHRLU),!
W ! S X="********** CHR REPORT NO. 5 **********" W $$CTR^BCHRLU(X,80)
W ! S X="NUMBER OF SERVICES (LINES OF ASSESSMENT) BY HEALTH PROBLEM, AGE AND SEX" W $$CTR^BCHRLU(X,80)
S BCHPROGN=$S(BCHPRG:$P(^BCHTPROG(BCHPRG,0),U)_" ("_$P(^(0),U,5)_")",1:"ALL"),X=$L(BCHPROGN)+10
W !!?((80-X)/2),"PROGRAM: ",BCHPROGN
S BCHPROVN=$S(BCHPROVT="O":$P(^VA(200,BCHCHR1,0),U),1:"ALL"),X=$L(BCHPROGN)+10
W !?((80-X)/2),"PROVIDER: ",BCHPROVN
S X=$L("PATIENTS: "_BCHREGN)
W !?((80-X)/2),"PATIENTS: ",BCHREGN
S X="REPORT DATES: "_BCHBDD_" TO "_BCHEDD W !,$$CTR^BCHRLU(X,80)
W !!,"HEALTH",?12,"-ALL AGES-" S J=24 F I=1:1:$L(BCHRBIN,";") S K=$P(BCHRBIN,";",I) Q:K="" W ?J,K S J=J+12
W !,"PROBLEM",?12,"M F" S J=24 F I=1:1:$L(BCHRBIN,";") W ?J,"M F" S J=J+12
W !,$TR($J(" ",80)," ","-")
Q
BCHRC5P ; IHS/CMI/LAB - print dx by age ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - tmp to xtmp
START ;
+1 SET Y=BCHBD
DO DD^%DT
SET BCHBDD=Y
SET Y=BCHED
DO DD^%DT
SET BCHEDD=Y
+2 SET Y=DT
DO DD^%DT
SET BCHDT=Y
+3 ;S BCHPG=0 D HEAD
+4 SET BCHPG=0
+5 KILL BCHQUIT
+6 IF '$DATA(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA"))
WRITE !!,"NO DATA TO REPORT"
GOTO DONE
HA ;
+1 ; LAB
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+2 ;
+3 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(BCHQUIT)
GOTO DONE
+4 ;S BCHTM=8888,BCHTF=7777
+5 WRITE !,"TOTAL",?8,$JUSTIFY(BCHTM,5),?14,$JUSTIFY(BCHTF,5)
+6 SET BCHX=0
SET J=20
FOR
SET BCHX=$ORDER(^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHX))
IF BCHX'=+BCHX!($DATA(BCHQUIT))
QUIT
Begin DoDot:1
+7 SET M=^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHX,"M")
SET F=^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHX,"F")
+8 ;S M=2222,F=3333
+9 WRITE ?J,$JUSTIFY(M,5)
SET J=J+6
WRITE ?J,$JUSTIFY(F,5)
SET J=J+6
+10 QUIT
End DoDot:1
+11 SET BCHX=0
FOR
SET BCHX=$ORDER(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX))
IF BCHX'=+BCHX!($DATA(BCHQUIT))
QUIT
Begin DoDot:1
+12 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(BCHQUIT)
QUIT
+13 ;," ",$E($P(^BCHTPROB(BCHX,0),U),1,5)
WRITE !?2,$PIECE(^BCHTPROB(BCHX,0),U,2)
+14 SET M=$SELECT($DATA(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,"TOTAL","M")):^("M"),1:0)
SET F=$SELECT($DATA(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,"TOTAL","F")):^("F"),1:0)
WRITE ?8,$JUSTIFY(M,5),?14,$JUSTIFY(F,5)
+15 SET J=20
FOR I=1:1:$LENGTH(BCHRBIN,";")
SET M=$SELECT($DATA(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,I,"M")):^("M"),1:".")
SET F=$SELECT($DATA(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHX,I,"F")):^("F"),1:".")
WRITE ?J,$JUSTIFY(M,5)
SET J=J+6
WRITE ?J,$JUSTIFY(F,5)
SET J=J+6
End DoDot:1
+16 ;
DONE DO DONE^BCHUTIL1
+1 KILL ^XTMP("BCHRC5",BCHJOB,BCHBT),BCHJOB,BCHBT,BCHX
+2 QUIT
HEAD ;
+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 BCHQUIT=""
QUIT
HEAD1 ; if terminal
+1 IF $DATA(IOF)
WRITE @IOF
HEAD2 ; if printer
+1 SET BCHPG=BCHPG+1
+2 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?30,"DATE GENERATED: ",BCHDT,?70,"Page ",BCHPG,!
+3 WRITE $$CTR^BCHRLU($$LOC^BCHRLU),!
+4 WRITE !
SET X="********** CHR REPORT NO. 5 **********"
WRITE $$CTR^BCHRLU(X,80)
+5 WRITE !
SET X="NUMBER OF SERVICES (LINES OF ASSESSMENT) BY HEALTH PROBLEM, AGE AND SEX"
WRITE $$CTR^BCHRLU(X,80)
+6 SET BCHPROGN=$SELECT(BCHPRG:$PIECE(^BCHTPROG(BCHPRG,0),U)_" ("_$PIECE(^(0),U,5)_")",1:"ALL")
SET X=$LENGTH(BCHPROGN)+10
+7 WRITE !!?((80-X)/2),"PROGRAM: ",BCHPROGN
+8 SET BCHPROVN=$SELECT(BCHPROVT="O":$PIECE(^VA(200,BCHCHR1,0),U),1:"ALL")
SET X=$LENGTH(BCHPROGN)+10
+9 WRITE !?((80-X)/2),"PROVIDER: ",BCHPROVN
+10 SET X=$LENGTH("PATIENTS: "_BCHREGN)
+11 WRITE !?((80-X)/2),"PATIENTS: ",BCHREGN
+12 SET X="REPORT DATES: "_BCHBDD_" TO "_BCHEDD
WRITE !,$$CTR^BCHRLU(X,80)
+13 WRITE !!,"HEALTH",?12,"-ALL AGES-"
SET J=24
FOR I=1:1:$LENGTH(BCHRBIN,";")
SET K=$PIECE(BCHRBIN,";",I)
IF K=""
QUIT
WRITE ?J,K
SET J=J+12
+14 WRITE !,"PROBLEM",?12,"M F"
SET J=24
FOR I=1:1:$LENGTH(BCHRBIN,";")
WRITE ?J,"M F"
SET J=J+12
+15 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+16 QUIT
