- 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 ;
