- 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
