APCLADXP ; IHS/CMI/LAB - print dx by age ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
START ;
S APCL132="",$P(APCL132,"-",130)=""
S Y=APCLBD D DD^%DT S APCLBDD=Y S Y=APCLED D DD^%DT S APCLEDD=Y
S (APCLPG,APCLCODE)=0 D HEAD
K APCLQUIT
F S APCLCODE=$O(^XTMP("APCLADX",APCLJOB,APCLBT,"TALLY",APCLCODE)) Q:APCLCODE=""!($D(APCLQUIT)) D AGE
G:$D(APCLQUIT) DONE
I $Y>(IOSL-4) D HEAD G:$D(APCLQUIT) DONE
W !,"TOTAL:" S J=39 F I=1:1:$L(APCLBIN,";") S K=$S($D(^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","AGE",I)):^(I),1:".") W ?J,$J(K,6) S J=J+9
W ?J,$J(APCLGRAN,6)
DONE D DONE^APCLOSUT
K ^XTMP("APCLADX",APCLJOB,APCLBT)
Q
AGE ;
I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT)
W !,APCLCODE S APCLNARR=$O(^XTMP("APCLADX",APCLJOB,APCLBT,"TALLY",APCLCODE,"")) W ?10,$E(APCLNARR,1,25)
N I,J,K S J=39 F I=1:1:$L(APCLBIN,";") S K=$S($D(^XTMP("APCLADX",APCLJOB,APCLBT,"TALLY",APCLCODE,APCLNARR,I)):^(I),1:".") W ?J,$J(K,6) S J=J+9
W ?J,$J(^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","CODE",APCLCODE,APCLNARR),6)
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),?(132-$L(X)/2),X,?120,"Page ",APCLPG,!
W ?54,"Diagnoses by Age Report",!
W ?5,"Visit Dates: ",APCLBDD," to ",APCLEDD,?52,"Type of Visit: ",$S($D(APCLTYPP):APCLTYPP,1:"ALL"),?90,"Service Category: ",$S($D(APCLSCP):APCLSCP,1:"ALL"),!
W ?5,"Location of Encounter: ",$S($D(APCLLOCP):$E(APCLLOCP,1,20),1:"ALL"),?52,"Clinic: ",$S($D(APCLCLNP):APCLCLNP,1:"ALL"),?90,"Sex of Patient: ",$S($D(APCLSEXP):APCLSEXP,1:"BOTH"),!
W ?5,"Primary Provider: ",$S($D(APCLPRVP):APCLPRVP,1:"ALL"),?52,"Purpose of Visits: ",$S($D(APCLPRIM):"Primary Only",1:"Primary and Seconday POV's"),!!?61,"AGE GROUPS"
N I,J,K W !,"ICD Code",?15,"ICD Narrative" S J=41 F I=1:1:$L(APCLBIN,";") S K=$P(APCLBIN,";",I) Q:K="" W ?J,K S J=J+9
W ?J,"TOTAL"
W !,APCL132
Q
APCLADXP ; IHS/CMI/LAB - print dx by age ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
START ;
+1 SET APCL132=""
SET $PIECE(APCL132,"-",130)=""
+2 SET Y=APCLBD
DO DD^%DT
SET APCLBDD=Y
SET Y=APCLED
DO DD^%DT
SET APCLEDD=Y
+3 SET (APCLPG,APCLCODE)=0
DO HEAD
+4 KILL APCLQUIT
+5 FOR
SET APCLCODE=$ORDER(^XTMP("APCLADX",APCLJOB,APCLBT,"TALLY",APCLCODE))
IF APCLCODE=""!($DATA(APCLQUIT))
QUIT
DO AGE
+6 IF $DATA(APCLQUIT)
GOTO DONE
+7 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
GOTO DONE
+8 WRITE !,"TOTAL:"
SET J=39
FOR I=1:1:$LENGTH(APCLBIN,";")
SET K=$SELECT($DATA(^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","AGE",I)):^(I),1:".")
WRITE ?J,$JUSTIFY(K,6)
SET J=J+9
+9 WRITE ?J,$JUSTIFY(APCLGRAN,6)
DONE DO DONE^APCLOSUT
+1 KILL ^XTMP("APCLADX",APCLJOB,APCLBT)
+2 QUIT
AGE ;
+1 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 WRITE !,APCLCODE
SET APCLNARR=$ORDER(^XTMP("APCLADX",APCLJOB,APCLBT,"TALLY",APCLCODE,""))
WRITE ?10,$EXTRACT(APCLNARR,1,25)
+3 NEW I,J,K
SET J=39
FOR I=1:1:$LENGTH(APCLBIN,";")
SET K=$SELECT($DATA(^XTMP("APCLADX",APCLJOB,APCLBT,"TALLY",APCLCODE,APCLNARR,I)):^(I),1:".")
WRITE ?J,$JUSTIFY(K,6)
SET J=J+9
+4 WRITE ?J,$JUSTIFY(^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","CODE",APCLCODE,APCLNARR),6)
+5 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),?(132-$LENGTH(X)/2),X,?120,"Page ",APCLPG,!
+5 WRITE ?54,"Diagnoses by Age Report",!
+6 WRITE ?5,"Visit Dates: ",APCLBDD," to ",APCLEDD,?52,"Type of Visit: ",$SELECT($DATA(APCLTYPP):APCLTYPP,1:"ALL"),?90,"Service Category: ",$SELECT($DATA(APCLSCP):APCLSCP,1:"ALL"),!
+7 WRITE ?5,"Location of Encounter: ",$SELECT($DATA(APCLLOCP):$EXTRACT(APCLLOCP,1,20),1:"ALL"),?52,"Clinic: ",$SELECT($DATA(APCLCLNP):APCLCLNP,1:"ALL"),?90,"Sex of Patient: ",$SELECT($DATA(APCLSEXP):APCLSEXP,1:"BOTH"),!
+8 WRITE ?5,"Primary Provider: ",$SELECT($DATA(APCLPRVP):APCLPRVP,1:"ALL"),?52,"Purpose of Visits: ",$SELECT($DATA(APCLPRIM):"Primary Only",1:"Primary and Seconday POV's"),!!?61,"AGE GROUPS"
+9 NEW I,J,K
WRITE !,"ICD Code",?15,"ICD Narrative"
SET J=41
FOR I=1:1:$LENGTH(APCLBIN,";")
SET K=$PIECE(APCLBIN,";",I)
IF K=""
QUIT
WRITE ?J,K
SET J=J+9
+10 WRITE ?J,"TOTAL"
+11 WRITE !,APCL132
+12 QUIT
