- APCLTEN1 ; IHS/CMI/LAB - TOP TEN POVS ;
- ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
- ;
- ;cmi/anch/maw 9/12/2007 code set versioning POVX
- ;
- VISIT ;
- S APCLJOB=$J,APCLBT=$H
- K ^XTMP("APCLTEN",APCLJOB,APCLBT)
- D XTMP^APCLOSUT("APCLTEN","PCC TOP TEN DX REPORT")
- S %="^XTMP(""APCLTEN"",APCLJOB,APCLBT,",APCLA=%_"""POV"",APCLPOV)",APCLB=%_"""APC"",APCLAPC)",APCLC=%_"1)",APCLE=%_"2)",APCLF=%_"3)",APCLG=%_"4)",APCLTOT=0,APCLVTOT=0,APCLLINO=0
- S APCLBD=APCLBD-.00001
- S APCLDATE=APCLBD F S APCLDATE=$O(^AUPNVSIT("B",APCLDATE)) Q:'APCLDATE Q:(APCLDATE\1)>APCLED F APCLVIEN=0:0 S APCLVIEN=$O(^AUPNVSIT("B",APCLDATE,APCLVIEN)) Q:'APCLVIEN I $D(^AUPNVSIT(APCLVIEN,0)),$D(^AUPNVPOV("AD",APCLVIEN)) D CK
- D SET
- S APCLET=$H
- Q
- ;
- CK ;
- S APCLVREC=^AUPNVSIT(APCLVIEN,0),DFN=$P(APCLVREC,U,5) I '$G(APCLSEAT) Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
- I $G(APCLSEAT),'$D(^DIBT(APCLSEAT,1,DFN)) Q ;not in search template
- Q:'$P(APCLVREC,U,9)
- Q:$P(APCLVREC,U,11)
- D SCREENS
- Q:$D(APCLSKIP)
- POV S APCLPOVN="",APCLVTOT=APCLVTOT+1,APCLCC=0
- F S APCLPOVN=$O(^AUPNVPOV("AD",APCLVIEN,APCLPOVN)) Q:'APCLPOVN Q:'$D(^AUPNVPOV(APCLPOVN,0)) S APCLPOV=+^(0),APCLCC=APCLCC+1,APCLPREC=^(0) D POVX
- Q
- ;
- POVX I '$D(^ICD9($P(APCLPREC,U))) Q
- I $D(APCLPRIM),$P(APCLVREC,U,7)="H",$P(APCLPREC,U,12)'="P" Q
- I $D(APCLPRIM),APCLCC>1 Q
- I APCLEXCL,$D(APCLDXT($P(APCLPREC,U))) Q ;excluded dx
- S APCLTOT=APCLTOT+1
- S %=$P($$ICDDX^ICDEX(APCLPOV),U,6) K APCLAPC I %,$D(^ICM(%,0)) S APCLAPC=%
- S APCLPAT=$P(^AUPNVPOV(APCLPOVN,0),U,2) I '$D(^XTMP("APCLTEN",APCLJOB,APCLBT,"PTIND",APCLPAT,APCLPOV)) D
- .S ^XTMP("APCLTEN",APCLJOB,APCLBT,"PTIND",APCLPAT,APCLPOV)=""
- .S ^XTMP("APCLTEN",APCLJOB,APCLBT,"PCOUNT",APCLPOV)=$G(^XTMP("APCLTEN",APCLJOB,APCLBT,"PCOUNT",APCLPOV))+1
- F X=APCLA,APCLB D UTL
- Q
- ;
- SCREENS ;
- K APCLSKIP
- S APCLI=0 F S APCLI=$O(^APCLVRPT(APCLRPT,11,APCLI)) Q:APCLI'=+APCLI!($D(APCLSKIP)) D
- .I '$P(^APCLVSTS(APCLI,0),U,8) D SINGLE Q
- .D MULT
- .Q
- Q
- SINGLE ;
- K X,APCLSPEC S X="",APCLX=0
- X:$D(^APCLVSTS(APCLI,1)) ^(1)
- I X="" S APCLSKIP="" Q
- I '$D(APCLSPEC),'$D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",X)) S APCLSKIP="" Q
- Q
- MULT ;
- K APCLFOUN,APCLSKIP,APCLSPEC,X S APCLX=0,X=""
- X:$D(^APCLVSTS(APCLI,1)) ^(1)
- I $O(X(""))="" S APCLSKIP="" Q
- I '$D(APCLSPEC) S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",Y)) S APCLFOUN="" Q
- I $D(APCLSPEC),$D(X) S APCLFOUN=1 Q
- S:'$D(APCLFOUN) APCLSKIP=""
- Q
- UTL I X=APCLB,'$D(APCLAPC) Q
- I '$D(@X) S @X=0
- S %=@X,%=%+1,@X=%
- Q
- ;
- SET F APCLPOV=0:0 S APCLPOV=$O(@APCLA) Q:'APCLPOV S %=^(APCLPOV),@APCLC@(9999999-%,APCLPOV)=""
- F APCLAPC=0:0 S APCLAPC=$O(@APCLB) Q:'APCLAPC S %=^(APCLAPC),@APCLE@(9999999-%,APCLAPC)=""
- S1 S (X,I)=0 F S X=$O(@APCLC@(X)) Q:'X F Y=0:0 S Y=$O(@APCLC@(X,Y)) Q:'Y S I=I+1,@APCLF@(I)=Y I I=APCLLNO G S2
- S2 S (X,I)=0 F S X=$O(@APCLE@(X)) Q:'X F Y=0:0 S Y=$O(@APCLE@(X,Y)) Q:'Y S I=I+1,@APCLG@(I)=Y I I=APCLLNO G S3
- S3 Q
- ;
- ;
- FF I IOST["P-" W:$D(IOF) @IOF Q
- I $E(IOST)="C",IO=IO(0),$Y>(IOSL-4) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S X="^"
- W:$D(IOF) @IOF
- Q
- ;
- EXIT ;EP
- K A,B,C,D,E,F,G,H,I,J,K,X,Y,Z,%
- K APCLBD,APCLED,APCLDOB1,APCLDOB2,APCLSEX,A,B,C,X,Y,Z,%,APCLFAC,APCLJOB,APCLLNO,E,F,G,ZTQUEUED,APCLCLN,APCLTYPE,APCLSC,APCLC,APCLPREC,APCLSD,APCLET,APCLSEAT,APCLCHRT,APCLLHDR,APCLDASH,APCLA,APCLB,APCLC,APCLD,APCLE,APCLF,APCLG
- K APCLQUIT,APCLAPC,APCLDATE,APCLPOV,APCLVIEN,APCLNOCK,APCLTOT,APCLPROV,APCLVTOT,APCLLINO,L,I,APCLCMA,APCLPOVN,APCLV,APCLTYPP,APCLSCP,APCLPRIM,APCLALL
- K APCLANS,AMQQTAX,APCLBDD,APCLCNT,APCLCRIT,APCLCTYP,APCLCUT,APCLDISP,APCLEDD,APCLHIGH,APCLI,APCLNCAN,APCLPTVS,APCLRPT,APCLSEL,APCLSKIP,APCLTCW,APCLTEXT,APCLVAR,APCLVIEN,APCLVREC,DFN,APCLX,APCLY,APCLCC
- K APCLBT
- Q
- APCLTEN1 ; IHS/CMI/LAB - TOP TEN POVS ;
- +1 ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
- +2 ;
- +3 ;cmi/anch/maw 9/12/2007 code set versioning POVX
- +4 ;
- VISIT ;
- +1 SET APCLJOB=$JOB
- SET APCLBT=$HOROLOG
- +2 KILL ^XTMP("APCLTEN",APCLJOB,APCLBT)
- +3 DO XTMP^APCLOSUT("APCLTEN","PCC TOP TEN DX REPORT")
- +4 SET %="^XTMP(""APCLTEN"",APCLJOB,APCLBT,"
- SET APCLA=%_"""POV"",APCLPOV)"
- SET APCLB=%_"""APC"",APCLAPC)"
- SET APCLC=%_"1)"
- SET APCLE=%_"2)"
- SET APCLF=%_"3)"
- SET APCLG=%_"4)"
- SET APCLTOT=0
- SET APCLVTOT=0
- SET APCLLINO=0
- +5 SET APCLBD=APCLBD-.00001
- +6 SET APCLDATE=APCLBD
- FOR
- SET APCLDATE=$ORDER(^AUPNVSIT("B",APCLDATE))
- IF 'APCLDATE
- QUIT
- IF (APCLDATE\1)>APCLED
- QUIT
- FOR APCLVIEN=0:0
- SET APCLVIEN=$ORDER(^AUPNVSIT("B",APCLDATE,APCLVIEN))
- IF 'APCLVIEN
- QUIT
- IF $DATA(^AUPNVSIT(APCLVIEN,0))
- IF $DATA(^AUPNVPOV("AD",APCLVIEN))
- DO CK
- +7 DO SET
- +8 SET APCLET=$HOROLOG
- +9 QUIT
- +10 ;
- CK ;
- +1 SET APCLVREC=^AUPNVSIT(APCLVIEN,0)
- SET DFN=$PIECE(APCLVREC,U,5)
- IF '$GET(APCLSEAT)
- IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
- QUIT
- +2 ;not in search template
- IF $GET(APCLSEAT)
- IF '$DATA(^DIBT(APCLSEAT,1,DFN))
- QUIT
- +3 IF '$PIECE(APCLVREC,U,9)
- QUIT
- +4 IF $PIECE(APCLVREC,U,11)
- QUIT
- +5 DO SCREENS
- +6 IF $DATA(APCLSKIP)
- QUIT
- POV SET APCLPOVN=""
- SET APCLVTOT=APCLVTOT+1
- SET APCLCC=0
- +1 FOR
- SET APCLPOVN=$ORDER(^AUPNVPOV("AD",APCLVIEN,APCLPOVN))
- IF 'APCLPOVN
- QUIT
- IF '$DATA(^AUPNVPOV(APCLPOVN,0))
- QUIT
- SET APCLPOV=+^(0)
- SET APCLCC=APCLCC+1
- SET APCLPREC=^(0)
- DO POVX
- +2 QUIT
- +3 ;
- POVX IF '$DATA(^ICD9($PIECE(APCLPREC,U)))
- QUIT
- +1 IF $DATA(APCLPRIM)
- IF $PIECE(APCLVREC,U,7)="H"
- IF $PIECE(APCLPREC,U,12)'="P"
- QUIT
- +2 IF $DATA(APCLPRIM)
- IF APCLCC>1
- QUIT
- +3 ;excluded dx
- IF APCLEXCL
- IF $DATA(APCLDXT($PIECE(APCLPREC,U)))
- QUIT
- +4 SET APCLTOT=APCLTOT+1
- +5 SET %=$PIECE($$ICDDX^ICDEX(APCLPOV),U,6)
- KILL APCLAPC
- IF %
- IF $DATA(^ICM(%,0))
- SET APCLAPC=%
- +6 SET APCLPAT=$PIECE(^AUPNVPOV(APCLPOVN,0),U,2)
- IF '$DATA(^XTMP("APCLTEN",APCLJOB,APCLBT,"PTIND",APCLPAT,APCLPOV))
- Begin DoDot:1
- +7 SET ^XTMP("APCLTEN",APCLJOB,APCLBT,"PTIND",APCLPAT,APCLPOV)=""
- +8 SET ^XTMP("APCLTEN",APCLJOB,APCLBT,"PCOUNT",APCLPOV)=$GET(^XTMP("APCLTEN",APCLJOB,APCLBT,"PCOUNT",APCLPOV))+1
- End DoDot:1
- +9 FOR X=APCLA,APCLB
- DO UTL
- +10 QUIT
- +11 ;
- SCREENS ;
- +1 KILL APCLSKIP
- +2 SET APCLI=0
- FOR
- SET APCLI=$ORDER(^APCLVRPT(APCLRPT,11,APCLI))
- IF APCLI'=+APCLI!($DATA(APCLSKIP))
- QUIT
- Begin DoDot:1
- +3 IF '$PIECE(^APCLVSTS(APCLI,0),U,8)
- DO SINGLE
- QUIT
- +4 DO MULT
- +5 QUIT
- End DoDot:1
- +6 QUIT
- SINGLE ;
- +1 KILL X,APCLSPEC
- SET X=""
- SET APCLX=0
- +2 IF $DATA(^APCLVSTS(APCLI,1))
- XECUTE ^(1)
- +3 IF X=""
- SET APCLSKIP=""
- QUIT
- +4 IF '$DATA(APCLSPEC)
- IF '$DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",X))
- SET APCLSKIP=""
- QUIT
- +5 QUIT
- MULT ;
- +1 KILL APCLFOUN,APCLSKIP,APCLSPEC,X
- SET APCLX=0
- SET X=""
- +2 IF $DATA(^APCLVSTS(APCLI,1))
- XECUTE ^(1)
- +3 IF $ORDER(X(""))=""
- SET APCLSKIP=""
- QUIT
- +4 IF '$DATA(APCLSPEC)
- SET Y=""
- FOR
- SET Y=$ORDER(X(Y))
- IF Y=""
- QUIT
- IF $DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",Y))
- SET APCLFOUN=""
- QUIT
- +5 IF $DATA(APCLSPEC)
- IF $DATA(X)
- SET APCLFOUN=1
- QUIT
- +6 IF '$DATA(APCLFOUN)
- SET APCLSKIP=""
- +7 QUIT
- UTL IF X=APCLB
- IF '$DATA(APCLAPC)
- QUIT
- +1 IF '$DATA(@X)
- SET @X=0
- +2 SET %=@X
- SET %=%+1
- SET @X=%
- +3 QUIT
- +4 ;
- SET FOR APCLPOV=0:0
- SET APCLPOV=$ORDER(@APCLA)
- IF 'APCLPOV
- QUIT
- SET %=^(APCLPOV)
- SET @APCLC@(9999999-%,APCLPOV)=""
- +1 FOR APCLAPC=0:0
- SET APCLAPC=$ORDER(@APCLB)
- IF 'APCLAPC
- QUIT
- SET %=^(APCLAPC)
- SET @APCLE@(9999999-%,APCLAPC)=""
- S1 SET (X,I)=0
- FOR
- SET X=$ORDER(@APCLC@(X))
- IF 'X
- QUIT
- FOR Y=0:0
- SET Y=$ORDER(@APCLC@(X,Y))
- IF 'Y
- QUIT
- SET I=I+1
- SET @APCLF@(I)=Y
- IF I=APCLLNO
- GOTO S2
- S2 SET (X,I)=0
- FOR
- SET X=$ORDER(@APCLE@(X))
- IF 'X
- QUIT
- FOR Y=0:0
- SET Y=$ORDER(@APCLE@(X,Y))
- IF 'Y
- QUIT
- SET I=I+1
- SET @APCLG@(I)=Y
- IF I=APCLLNO
- GOTO S3
- S3 QUIT
- +1 ;
- +2 ;
- FF IF IOST["P-"
- IF $DATA(IOF)
- WRITE @IOF
- QUIT
- +1 IF $EXTRACT(IOST)="C"
- IF IO=IO(0)
- IF $Y>(IOSL-4)
- WRITE !
- SET DIR(0)="EO"
- DO ^DIR
- KILL DIR
- IF Y=0!(Y="^")!($DATA(DTOUT))
- SET X="^"
- +2 IF $DATA(IOF)
- WRITE @IOF
- +3 QUIT
- +4 ;
- EXIT ;EP
- +1 KILL A,B,C,D,E,F,G,H,I,J,K,X,Y,Z,%
- +2 KILL APCLBD,APCLED,APCLDOB1,APCLDOB2,APCLSEX,A,B,C,X,Y,Z,%,APCLFAC,APCLJOB,APCLLNO,E,F,G,ZTQUEUED,APCLCLN,APCLTYPE,APCLSC,APCLC,APCLPREC,APCLSD,APCLET,APCLSEAT,APCLCHRT,APCLLHDR,APCLDASH,APCLA,APCLB,APCLC,APCLD,APCLE,APCLF,APCLG
- +3 KILL APCLQUIT,APCLAPC,APCLDATE,APCLPOV,APCLVIEN,APCLNOCK,APCLTOT,APCLPROV,APCLVTOT,APCLLINO,L,I,APCLCMA,APCLPOVN,APCLV,APCLTYPP,APCLSCP,APCLPRIM,APCLALL
- +4 KILL APCLANS,AMQQTAX,APCLBDD,APCLCNT,APCLCRIT,APCLCTYP,APCLCUT,APCLDISP,APCLEDD,APCLHIGH,APCLI,APCLNCAN,APCLPTVS,APCLRPT,APCLSEL,APCLSKIP,APCLTCW,APCLTEXT,APCLVAR,APCLVIEN,APCLVREC,DFN,APCLX,APCLY,APCLCC
- +5 KILL APCLBT
- +6 QUIT
