APCLCP91 ; IHS/CMI/LAB - APC report - process ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
START ; EP - process report
S APCLBT=$H,APCLJOB=$J
K ^XTMP("APCLCP9",APCLJOB,APCLBT)
D XTMP^APCLOSUT("APCLCP9","PCC ACTIVITY REPORT")
I $P(^APCLACTG(APCLACTG,0),U,2)]"",$P(^(0),U,3)]"",$P(^(0),U,4)]"" D I 1
.S APCLRRTN=$S($P($P(^APCLACTG(APCLACTG,0),U,2),"~",2)]"":$P($P(^APCLACTG(APCLACTG,0),U,2),"~")_"^"_$P($P(^APCLACTG(APCLACTG,0),U,2),"~",2),1:$P(^APCLACTG(APCLACTG,0),U,2)),APCLPIEC=$P(^(0),U,4),APCLGLOB="^"_$P(^(0),U,3)_"("
.S X=APCLRRTN X ^%ZOSF("TEST") I '$T S APCLRRTN="",APCLGLOB="^ICD9(",APCLPIEC=3 Q
E S APCLGLOB="^ICD9(",APCLRRTN="",APCLPIEC=3
I APCLRRTN]"" S APCLRRTN="^"_APCLRRTN
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
D SET
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) I $P(APCLVREC,U,9),'$P(APCLVREC,U,11),$D(^AUPNVPOV("AD",APCLVDFN)),$D(^AUPNVPRV("AD",APCLVDFN)) D PROC
Q
PROC ;
K APCLSKIP
Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
Q:"DXECH"[$P(APCLVREC,U,7)
Q:$D(^APCLCNTL(4,11,"AC",$P(APCLVREC,U,3)))
I $D(APCLCLN) Q:$P(APCLVREC,U,8)="" I '$D(APCLCLN($P(APCLVREC,U,8))) Q
S (APCL1,APCL2)=0 F S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2="" I $P(^AUPNVPRV(APCL2,0),U,4)="P" S APCL1=APCL1+1
I APCL1=0 Q
I APCL1>1 Q
S APCLVLOC=$P(APCLVREC,U,6)
S APCLSU=$P(^AUTTLOC(APCLVLOC,0),U,5)
Q:APCLSU'=APCLSUF
S APCLFOUN=0 D PROC2
Q:'APCLFOUN
D SETCODE
Q
EOJ K APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLPRIM,APCLSU,APCLDISC,APCLCODE,APCLVTM,APCLVTT
Q
;
;
PROC2 ;
S APCLX=0 F S APCLX=$O(^AUPNVPRV("AD",APCLVDFN,APCLX)) Q:APCLX'=+APCLX!(APCLFOUN) S APCLCHN=APCLX D
. S APCLAP=$P(^AUPNVPRV(APCLX,0),U)
. I $P(^DD(9000010.06,.01,0),U,2)[200 S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) Q:'$D(^APCLACTG(APCLACTG,11,"AC",APCLDISC)) S APCLFOUN=1 Q
. S APCLY=$P(^DIC(6,APCLAP,0),U,4)
. I APCLY="" Q
. I '$D(^DIC(7,APCLY,9999999)) Q
. Q:'$D(^APCLACTG(APCLACTG,11,"AC",$P(^DIC(7,APCLY,9999999),U)))
. S APCLFOUN=1
. Q
Q
SETCODE ;
S APCLCODE="" D GETCODE
Q:'APCLCODE
S ^("TOTAL")=$S($D(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSU,APCLCODE,"TOTAL")):^("TOTAL")+1,1:1)
Q
GETCODE ;
D GETPPOV
S APCLIPTR=$P(^AUPNVPOV(APCL1,0),U)
I $G(APCLRRTN)]"" D @APCLRRTN Q
S APCLCODE=APCLIPTR
Q
GETPPOV ;
I $P(APCLVREC,U,7)'="H" S APCL1=$O(^AUPNVPOV("AD",APCLVDFN,"")) Q
S (APCL1,APCL2)=0 F S APCL2=$O(^AUPNVPOV("AD",APCLVDFN,APCL2)) Q:APCL2'=+APCL2!(APCL1) I $P(^AUPNVPOV(APCL2,0),U,12)="P" S APCL1=APCL2
Q
SET ;
S X=0 F S X=$O(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,X)) Q:X'=+X S Y=^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,X,"TOTAL"),^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,"TOP TEN",9999999-Y,X)=Y
Q
APCLCP91 ; IHS/CMI/LAB - APC report - process ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
START ; EP - process report
+1 SET APCLBT=$HOROLOG
SET APCLJOB=$JOB
+2 KILL ^XTMP("APCLCP9",APCLJOB,APCLBT)
+3 DO XTMP^APCLOSUT("APCLCP9","PCC ACTIVITY REPORT")
+4 IF $PIECE(^APCLACTG(APCLACTG,0),U,2)]""
IF $PIECE(^(0),U,3)]""
IF $PIECE(^(0),U,4)]""
Begin DoDot:1
+5 SET APCLRRTN=$SELECT($PIECE($PIECE(^APCLACTG(APCLACTG,0),U,2),"~",2)]"":$PIECE($PIECE(^APCLACTG(APCLACTG,0),U,2),"~")_"^"_$PIECE($PIECE(^APCLACTG(APCLACTG,0),U,2),"~",2),1:$PIECE(^APCLACTG(APCLACTG,0),U,2))
SET APCLPIEC=$PIECE(^(0),U,4)
SET APCLGLOB="^"_$PIECE(^(0),U,3)_"("
+6 SET X=APCLRRTN
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET APCLRRTN=""
SET APCLGLOB="^ICD9("
SET APCLPIEC=3
QUIT
End DoDot:1
IF 1
+7 IF '$TEST
SET APCLGLOB="^ICD9("
SET APCLRRTN=""
SET APCLPIEC=3
+8 IF APCLRRTN]""
SET APCLRRTN="^"_APCLRRTN
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 DO SET
+4 SET APCLET=$HOROLOG
+5 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)
IF $PIECE(APCLVREC,U,9)
IF '$PIECE(APCLVREC,U,11)
IF $DATA(^AUPNVPOV("AD",APCLVDFN))
IF $DATA(^AUPNVPRV("AD",APCLVDFN))
DO PROC
+2 QUIT
PROC ;
+1 KILL APCLSKIP
+2 IF $$DEMO^APCLUTL($PIECE(APCLVREC,U,5),$GET(APCLDEMO))
QUIT
+3 IF "DXECH"[$PIECE(APCLVREC,U,7)
QUIT
+4 IF $DATA(^APCLCNTL(4,11,"AC",$PIECE(APCLVREC,U,3)))
QUIT
+5 IF $DATA(APCLCLN)
IF $PIECE(APCLVREC,U,8)=""
QUIT
IF '$DATA(APCLCLN($PIECE(APCLVREC,U,8)))
QUIT
+6 SET (APCL1,APCL2)=0
FOR
SET APCL2=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCL2))
IF APCL2=""
QUIT
IF $PIECE(^AUPNVPRV(APCL2,0),U,4)="P"
SET APCL1=APCL1+1
+7 IF APCL1=0
QUIT
+8 IF APCL1>1
QUIT
+9 SET APCLVLOC=$PIECE(APCLVREC,U,6)
+10 SET APCLSU=$PIECE(^AUTTLOC(APCLVLOC,0),U,5)
+11 IF APCLSU'=APCLSUF
QUIT
+12 SET APCLFOUN=0
DO PROC2
+13 IF 'APCLFOUN
QUIT
+14 DO SETCODE
+15 QUIT
EOJ KILL APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLPRIM,APCLSU,APCLDISC,APCLCODE,APCLVTM,APCLVTT
+1 QUIT
+2 ;
+3 ;
PROC2 ;
+1 SET APCLX=0
FOR
SET APCLX=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCLX))
IF APCLX'=+APCLX!(APCLFOUN)
QUIT
SET APCLCHN=APCLX
Begin DoDot:1
+2 SET APCLAP=$PIECE(^AUPNVPRV(APCLX,0),U)
+3 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
IF '$DATA(^APCLACTG(APCLACTG,11,"AC",APCLDISC))
QUIT
SET APCLFOUN=1
QUIT
+4 SET APCLY=$PIECE(^DIC(6,APCLAP,0),U,4)
+5 IF APCLY=""
QUIT
+6 IF '$DATA(^DIC(7,APCLY,9999999))
QUIT
+7 IF '$DATA(^APCLACTG(APCLACTG,11,"AC",$PIECE(^DIC(7,APCLY,9999999),U)))
QUIT
+8 SET APCLFOUN=1
+9 QUIT
End DoDot:1
+10 QUIT
SETCODE ;
+1 SET APCLCODE=""
DO GETCODE
+2 IF 'APCLCODE
QUIT
+3 SET ^("TOTAL")=$SELECT($DATA(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSU,APCLCODE,"TOTAL")):^("TOTAL")+1,1:1)
+4 QUIT
GETCODE ;
+1 DO GETPPOV
+2 SET APCLIPTR=$PIECE(^AUPNVPOV(APCL1,0),U)
+3 IF $GET(APCLRRTN)]""
DO @APCLRRTN
QUIT
+4 SET APCLCODE=APCLIPTR
+5 QUIT
GETPPOV ;
+1 IF $PIECE(APCLVREC,U,7)'="H"
SET APCL1=$ORDER(^AUPNVPOV("AD",APCLVDFN,""))
QUIT
+2 SET (APCL1,APCL2)=0
FOR
SET APCL2=$ORDER(^AUPNVPOV("AD",APCLVDFN,APCL2))
IF APCL2'=+APCL2!(APCL1)
QUIT
IF $PIECE(^AUPNVPOV(APCL2,0),U,12)="P"
SET APCL1=APCL2
+3 QUIT
SET ;
+1 SET X=0
FOR
SET X=$ORDER(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,X))
IF X'=+X
QUIT
SET Y=^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,X,"TOTAL")
SET ^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,"TOP TEN",9999999-Y,X)=Y
+2 QUIT
