- APCLCP11 ; IHS/CMI/LAB - tally activity time ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;
- START ;
- S APCLJOB=$J,APCLBT=$H
- 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
- K ^XTMP(APCLNSP,APCLJOB,APCLBT)
- D XTMP^APCLOSUT(APCLNSP,"PCC ACTIVITY REPORT")
- S APCLODAT=$O(^AUPNVSIT("B",APCLSD)) G:APCLODAT="" END
- S APCLODAT=APCLSD_".9999" F S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED) D V1
- END ;
- D EOJ
- 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(^AUPNVPRV("AD",APCLVDFN)),$D(^AUPNVPOV("AD",APCLVDFN)) D PROC,EOJ
- Q
- PROC ;
- K APCLSKIP
- Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
- Q:"EXCH"[$P(APCLVREC,U,7)
- Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3))) ;IHS/CMI/LAB
- I $D(APCLLOC) Q:$P(APCLVREC,U,6)="" I '$D(APCLLOC($P(APCLVREC,U,6))) Q
- 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,APCLAP=$P(^(0),U)
- Q:APCL1=0
- Q:APCL1>1
- S APCLVLOC=$P(APCLVREC,U,6)
- D PROC2
- Q
- EOJ K APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLPRIM,@APCLSORV,APCLDISC,APCLVLOC,APCLVTM,APCLVTT,APCLCODE,APCLIPTR
- Q
- ;
- ;
- PROC2 ;
- S APCLZ=0 F S APCLZ=$O(^AUPNVPRV("AD",APCLVDFN,APCLZ)) Q:APCLZ'=+APCLZ D
- . S APCLAP=$P(^AUPNVPRV(APCLZ,0),U)
- . I $P(^DD(9000010.06,.01,0),U,2)[200 S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) G PROC21
- . S APCLY=$P(^DIC(6,APCLAP,0),U,4)
- . Q:APCLY=""
- . Q:'$D(^DIC(7,APCLY,9999999))
- . S APCLDISC=$P(^DIC(7,APCLY,9999999),U)
- PROC21 . I '$D(^APCLACTG(APCLACTG,11,"AC",APCLDISC)) Q
- . I APCLSORV="APCLCODE" D GETCODE Q:'APCLCODE
- . S ^("TOTAL")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"TOTAL")):^("TOTAL")+1,1:1)
- . I $P(^AUPNVPRV(APCLZ,0),U,4)="P" S ^("PRIM")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"PRIM")):^("PRIM")+1,1:1)
- . I $P(^AUPNVPRV(APCLZ,0),U,4)'="P" S ^("SEC")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"SEC")):^("SEC")+1,1:1)
- . I '$D(^AUPNVTM("AD",APCLVDFN)) S ^("NOACT")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,"NOACT")):^("NOACT")+1,1:1) Q
- . S APCLVTM=$O(^AUPNVTM("AD",APCLVDFN,"")),APCLVACT=$P(^AUPNVTM(APCLVTM,0),U),APCLVTT=$P(^AUPNVTM(APCLVTM,0),U,4)
- . S ^("ACT")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"ACT")):^("ACT")+APCLVACT,1:APCLVACT)
- . I APCLVTT S ^("TT")=$S($D(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"TT")):^("TT")+APCLVTT,1:APCLVTT)
- . Q
- 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
- APCLCP11 ; IHS/CMI/LAB - tally activity time ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;
- START ;
- +1 SET APCLJOB=$JOB
- SET APCLBT=$HOROLOG
- +2 IF $PIECE(^APCLACTG(APCLACTG,0),U,2)]""
- IF $PIECE(^(0),U,3)]""
- IF $PIECE(^(0),U,4)]""
- Begin DoDot:1
- +3 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)_"("
- +4 SET X=APCLRRTN
- XECUTE ^%ZOSF("TEST")
- IF '$TEST
- SET APCLRRTN=""
- SET APCLGLOB="^ICD9("
- SET APCLPIEC=3
- QUIT
- End DoDot:1
- IF 1
- +5 IF '$TEST
- SET APCLGLOB="^ICD9("
- SET APCLRRTN=""
- SET APCLPIEC=3
- +6 IF APCLRRTN]""
- SET APCLRRTN="^"_APCLRRTN
- V ; Run by visit date
- +1 KILL ^XTMP(APCLNSP,APCLJOB,APCLBT)
- +2 DO XTMP^APCLOSUT(APCLNSP,"PCC ACTIVITY REPORT")
- +3 SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLSD))
- IF APCLODAT=""
- GOTO END
- +4 SET APCLODAT=APCLSD_".9999"
- FOR
- SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
- IF APCLODAT=""!((APCLODAT\1)>APCLED)
- QUIT
- DO V1
- END ;
- +1 DO EOJ
- +2 SET APCLET=$HOROLOG
- +3 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(^AUPNVPRV("AD",APCLVDFN))
- IF $DATA(^AUPNVPOV("AD",APCLVDFN))
- DO PROC
- DO EOJ
- +2 QUIT
- PROC ;
- +1 KILL APCLSKIP
- +2 IF $$DEMO^APCLUTL($PIECE(APCLVREC,U,5),$GET(APCLDEMO))
- QUIT
- +3 IF "EXCH"[$PIECE(APCLVREC,U,7)
- QUIT
- +4 ;IHS/CMI/LAB
- IF $DATA(^APCLCNTL(4,11,"B",$PIECE(APCLVREC,U,3)))
- QUIT
- +5 IF $DATA(APCLLOC)
- IF $PIECE(APCLVREC,U,6)=""
- QUIT
- IF '$DATA(APCLLOC($PIECE(APCLVREC,U,6)))
- QUIT
- +6 IF $DATA(APCLCLN)
- IF $PIECE(APCLVREC,U,8)=""
- QUIT
- IF '$DATA(APCLCLN($PIECE(APCLVREC,U,8)))
- QUIT
- +7 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
- SET APCLAP=$PIECE(^(0),U)
- +8 IF APCL1=0
- QUIT
- +9 IF APCL1>1
- QUIT
- +10 SET APCLVLOC=$PIECE(APCLVREC,U,6)
- +11 DO PROC2
- +12 QUIT
- EOJ KILL APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLPRIM,@APCLSORV,APCLDISC,APCLVLOC,APCLVTM,APCLVTT,APCLCODE,APCLIPTR
- +1 QUIT
- +2 ;
- +3 ;
- PROC2 ;
- +1 SET APCLZ=0
- FOR
- SET APCLZ=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCLZ))
- IF APCLZ'=+APCLZ
- QUIT
- Begin DoDot:1
- +2 SET APCLAP=$PIECE(^AUPNVPRV(APCLZ,0),U)
- +3 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
- SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
- GOTO PROC21
- +4 SET APCLY=$PIECE(^DIC(6,APCLAP,0),U,4)
- +5 IF APCLY=""
- QUIT
- +6 IF '$DATA(^DIC(7,APCLY,9999999))
- QUIT
- +7 SET APCLDISC=$PIECE(^DIC(7,APCLY,9999999),U)
- PROC21 IF '$DATA(^APCLACTG(APCLACTG,11,"AC",APCLDISC))
- QUIT
- +1 IF APCLSORV="APCLCODE"
- DO GETCODE
- IF 'APCLCODE
- QUIT
- +2 SET ^("TOTAL")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"TOTAL")):^("TOTAL")+1,1:1)
- +3 IF $PIECE(^AUPNVPRV(APCLZ,0),U,4)="P"
- SET ^("PRIM")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"PRIM")):^("PRIM")+1,1:1)
- +4 IF $PIECE(^AUPNVPRV(APCLZ,0),U,4)'="P"
- SET ^("SEC")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"SEC")):^("SEC")+1,1:1)
- +5 IF '$DATA(^AUPNVTM("AD",APCLVDFN))
- SET ^("NOACT")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,"NOACT")):^("NOACT")+1,1:1)
- QUIT
- +6 SET APCLVTM=$ORDER(^AUPNVTM("AD",APCLVDFN,""))
- SET APCLVACT=$PIECE(^AUPNVTM(APCLVTM,0),U)
- SET APCLVTT=$PIECE(^AUPNVTM(APCLVTM,0),U,4)
- +7 SET ^("ACT")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"ACT")):^("ACT")+APCLVACT,1:APCLVACT)
- +8 IF APCLVTT
- SET ^("TT")=$SELECT($DATA(^XTMP(APCLNSP,APCLJOB,APCLBT,APCLAP,@APCLSORV,"TT")):^("TT")+APCLVTT,1:APCLVTT)
- +9 QUIT
- End DoDot:1
- +10 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
