APCLADX1 ; IHS/CMI/LAB - process dx by age report ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/7/2007 code set versioning in POVX
;
S APCLBT=$H,APCLJOB=$J,APCLGRAN=0
D XTMP^APCLOSUT("APCLADX","PCC DX BY AGE REPORT")
S APCLNN=APCLBIN,APCLA="" F I=1:1 S APCLX=$P(APCLNN,";",I) Q:APCLX="" D SETA
S APCLDOBS=APCLA
V ; Run by visit date
S APCLODAT=$O(^AUPNVSIT("B",APCLSD)) I APCLODAT="" S APCLET=$H Q
S APCLODAT=APCLSD_".9999" F S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED) D V1
S APCLET=$H
Q
V1 ;
S APCLVDFN=0 F S APCLVDFN=$O(^AUPNVSIT("B",APCLODAT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN I $D(^AUPNVSIT(APCLVDFN,0)) S APCLVREC=^(0) D PROC,EOJ
Q
PROC ;
K APCLSKIP
Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
Q:'$P(APCLVREC,U,9)
Q:$P(APCLVREC,U,11)
I $D(APCLSC),$P(APCLVREC,U,7)'=APCLSC Q
I $D(APCLTYPE),$P(APCLVREC,U,3)'=APCLTYPE Q
S APCLF2=$P(APCLVREC,U,5) Q:'APCLF2 Q:'$D(^DPT(APCLF2,0)) S APCLF2=^(0)
I $D(APCLSEX),APCLSEX'=$P(APCLF2,U,2) Q
I $D(APCLFAC),APCLFAC'=$P(APCLVREC,U,6) Q
PROV I '$D(APCLPROV) G CLN
N % K APCLFOUN S %="" F S %=$O(^AUPNVPRV("AD",APCLVDFN,%)) Q:%="" I $D(^AUPNVPRV(%,0)),$P(^(0),U,4)="P",APCLPROV=+^(0) S APCLFOUN=""
Q:'$D(APCLFOUN)
CLN I $D(APCLCLN),APCLCLN'=$P(APCLVREC,U,8) Q
Q:'$D(^AUPNVPOV("AD",APCLVDFN))
POV S APCLPOVN=""
S APCLC=0 F S APCLPOVN=$O(^AUPNVPOV("AD",APCLVDFN,APCLPOVN)) Q:'APCLPOVN Q:'$D(^AUPNVPOV(APCLPOVN,0)) S APCLPOV=+^(0),APCLPREC=^(0),APCLC=APCLC+1 D POVX
Q
;
POVX ;
;I '$D(^ICD9($P(APCLPREC,U))) Q
I +$$ICDDX^ICDEX(APCLPOV)=-1 Q
I $D(APCLPRIM),$D(APCLSC),APCLSC="H",$P(APCLPREC,U,12)'="P" Q
I $D(APCLPRIM),APCLC>1 Q
;S APCLCODE=$P(^ICD9(APCLPOV,0),U)_" ",APCLNARR=$P(^(0),U,3)
S APCLCODE=$$VAL^XBDIQ1(9000010.07,APCLPOVN,.01)_" ",APCLNARR=$P($$ICDDX^ICDEX(APCLPOV),U,4)
D SET
Q
EOJ K APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLDISC,APCLAGE
Q
;
;
SET ;
S APCLAGE="" D GETAGE
Q:'APCLAGE
S ^(APCLNARR)=$S($D(^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","CODE",APCLCODE,APCLNARR)):^(APCLNARR)+1,1:1)
S ^(APCLAGE)=$S($D(^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","AGE",APCLAGE)):^(APCLAGE)+1,1:1)
S ^(APCLAGE)=$S($D(^XTMP("APCLADX",APCLJOB,APCLBT,"TALLY",APCLCODE,APCLNARR,APCLAGE)):^(APCLAGE)+1,1:1)
S APCLGRAN=APCLGRAN+1
Q
GETAGE ;
S APCLDOB=$P(^DPT($P(APCLVREC,U,5),0),U,3) Q:APCLDOB=""
ATT ;
F I=1:1 S APCLNN=$P(APCLA,";",I) Q:APCLNN="" S APCLX=$P(APCLNN,"-"),APCLY=$P(APCLNN,"-",2) I APCLDOB'<APCLX,APCLDOB'>APCLY S APCLAGE=I Q
Q
;
SETA S APCLY=$P(APCLX,"-"),APCLZ=$P(APCLX,"-",2)
I APCLA]"" S APCLA=APCLA_";"
S APCLA=APCLA_(DT+1-(10000*(APCLZ+1)))_"-"_(DT-(APCLY*10000))
S ^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","AGE",I)=0
Q
;
APCLADX1 ; IHS/CMI/LAB - process dx by age report ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/7/2007 code set versioning in POVX
+4 ;
+5 SET APCLBT=$HOROLOG
SET APCLJOB=$JOB
SET APCLGRAN=0
+6 DO XTMP^APCLOSUT("APCLADX","PCC DX BY AGE REPORT")
+7 SET APCLNN=APCLBIN
SET APCLA=""
FOR I=1:1
SET APCLX=$PIECE(APCLNN,";",I)
IF APCLX=""
QUIT
DO SETA
+8 SET APCLDOBS=APCLA
V ; Run by visit date
+1 SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLSD))
IF APCLODAT=""
SET APCLET=$HOROLOG
QUIT
+2 SET APCLODAT=APCLSD_".9999"
FOR
SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
IF APCLODAT=""!((APCLODAT\1)>APCLED)
QUIT
DO V1
+3 SET APCLET=$HOROLOG
+4 QUIT
V1 ;
+1 SET APCLVDFN=0
FOR
SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVDFN))
IF APCLVDFN'=+APCLVDFN
QUIT
IF $DATA(^AUPNVSIT(APCLVDFN,0))
SET APCLVREC=^(0)
DO PROC
DO EOJ
+2 QUIT
PROC ;
+1 KILL APCLSKIP
+2 IF $$DEMO^APCLUTL($PIECE(APCLVREC,U,5),$GET(APCLDEMO))
QUIT
+3 IF '$PIECE(APCLVREC,U,9)
QUIT
+4 IF $PIECE(APCLVREC,U,11)
QUIT
+5 IF $DATA(APCLSC)
IF $PIECE(APCLVREC,U,7)'=APCLSC
QUIT
+6 IF $DATA(APCLTYPE)
IF $PIECE(APCLVREC,U,3)'=APCLTYPE
QUIT
+7 SET APCLF2=$PIECE(APCLVREC,U,5)
IF 'APCLF2
QUIT
IF '$DATA(^DPT(APCLF2,0))
QUIT
SET APCLF2=^(0)
+8 IF $DATA(APCLSEX)
IF APCLSEX'=$PIECE(APCLF2,U,2)
QUIT
+9 IF $DATA(APCLFAC)
IF APCLFAC'=$PIECE(APCLVREC,U,6)
QUIT
PROV IF '$DATA(APCLPROV)
GOTO CLN
+1 NEW %
KILL APCLFOUN
SET %=""
FOR
SET %=$ORDER(^AUPNVPRV("AD",APCLVDFN,%))
IF %=""
QUIT
IF $DATA(^AUPNVPRV(%,0))
IF $PIECE(^(0),U,4)="P"
IF APCLPROV=+^(0)
SET APCLFOUN=""
+2 IF '$DATA(APCLFOUN)
QUIT
CLN IF $DATA(APCLCLN)
IF APCLCLN'=$PIECE(APCLVREC,U,8)
QUIT
+1 IF '$DATA(^AUPNVPOV("AD",APCLVDFN))
QUIT
POV SET APCLPOVN=""
+1 SET APCLC=0
FOR
SET APCLPOVN=$ORDER(^AUPNVPOV("AD",APCLVDFN,APCLPOVN))
IF 'APCLPOVN
QUIT
IF '$DATA(^AUPNVPOV(APCLPOVN,0))
QUIT
SET APCLPOV=+^(0)
SET APCLPREC=^(0)
SET APCLC=APCLC+1
DO POVX
+2 QUIT
+3 ;
POVX ;
+1 ;I '$D(^ICD9($P(APCLPREC,U))) Q
+2 IF +$$ICDDX^ICDEX(APCLPOV)=-1
QUIT
+3 IF $DATA(APCLPRIM)
IF $DATA(APCLSC)
IF APCLSC="H"
IF $PIECE(APCLPREC,U,12)'="P"
QUIT
+4 IF $DATA(APCLPRIM)
IF APCLC>1
QUIT
+5 ;S APCLCODE=$P(^ICD9(APCLPOV,0),U)_" ",APCLNARR=$P(^(0),U,3)
+6 SET APCLCODE=$$VAL^XBDIQ1(9000010.07,APCLPOVN,.01)_" "
SET APCLNARR=$PIECE($$ICDDX^ICDEX(APCLPOV),U,4)
+7 DO SET
+8 QUIT
EOJ KILL APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLDISC,APCLAGE
+1 QUIT
+2 ;
+3 ;
SET ;
+1 SET APCLAGE=""
DO GETAGE
+2 IF 'APCLAGE
QUIT
+3 SET ^(APCLNARR)=$SELECT($DATA(^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","CODE",APCLCODE,APCLNARR)):^(APCLNARR)+1,1:1)
+4 SET ^(APCLAGE)=$SELECT($DATA(^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","AGE",APCLAGE)):^(APCLAGE)+1,1:1)
+5 SET ^(APCLAGE)=$SELECT($DATA(^XTMP("APCLADX",APCLJOB,APCLBT,"TALLY",APCLCODE,APCLNARR,APCLAGE)):^(APCLAGE)+1,1:1)
+6 SET APCLGRAN=APCLGRAN+1
+7 QUIT
GETAGE ;
+1 SET APCLDOB=$PIECE(^DPT($PIECE(APCLVREC,U,5),0),U,3)
IF APCLDOB=""
QUIT
ATT ;
+1 FOR I=1:1
SET APCLNN=$PIECE(APCLA,";",I)
IF APCLNN=""
QUIT
SET APCLX=$PIECE(APCLNN,"-")
SET APCLY=$PIECE(APCLNN,"-",2)
IF APCLDOB'<APCLX
IF APCLDOB'>APCLY
SET APCLAGE=I
QUIT
+2 QUIT
+3 ;
SETA SET APCLY=$PIECE(APCLX,"-")
SET APCLZ=$PIECE(APCLX,"-",2)
+1 IF APCLA]""
SET APCLA=APCLA_";"
+2 SET APCLA=APCLA_(DT+1-(10000*(APCLZ+1)))_"-"_(DT-(APCLY*10000))
+3 SET ^XTMP("APCLADX",APCLJOB,APCLBT,"TOTAL","AGE",I)=0
+4 QUIT
+5 ;
