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
