IBDFOSG4 ;ALB/MAF/AAS - NUMBER OF ENCOUNTERS WITH CPT'S AND DX'S CONT. ; 3/18/96
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
START ; -- Loop thru MONTHS
N IBQUIT
S IBQUIT=0
S ^TMP("GTOT",$J)="0^0^0"
BLD ; -- scan ENCOUNTERS
F IBDDT=IBDFBEG:0 S IBDDT=$O(^SCE("B",IBDDT)) Q:'IBDDT!($P(IBDDT,".",1)>IBDFEND) D
.F IBIFN=0:0 S IBIFN=$O(^SCE("B",IBDDT,IBIFN)) Q:'IBIFN S IBNODE=$G(^SCE(IBIFN,0)) D
..S IBDIV=$P(IBNODE,"^",11) ;division
..S IBDIVNM=$P($$SITE^VASITE(,+IBDIV),"^",3)
..I VAUTD=0 Q:'$D(VAUTD(+IBDIV))
..S IBDFN=$P(IBNODE,"^",2) ;patient
..S IBSTOP=$P(IBNODE,"^",3) ;stop code
..S IBCLIN=$P(IBNODE,"^",4) ;clinic
..S IBPARNT=$P(IBNODE,"^",6) ;parent
..S IBPROC=$P(IBNODE,"^",8) ;process
..S IBMNTH=$E($P(IBNODE,"^"),1,3)_$E($P(IBNODE,"^"),4,5) ;number of month
..Q:'IBDFN
..D PROC I $D(IBXY) S IBPIECE=2 D SET
..D SET^SDCO4(IBIFN) I $D(SDDXY) S IBPIECE=3 D SET
..Q
Q
;
;
SET ; -- Set totals
I '$D(^TMP("DTOT",$J,IBDIVNM)) S ^TMP("DTOT",$J,IBDIVNM)="0^0^0"
I '$D(^TMP("MNTH",$J,IBDIVNM,IBMNTH)) S ^TMP("MNTH",$J,IBDIVNM,IBMNTH)="0^0^0"
S $P(^TMP("MNTH",$J,IBDIVNM,IBMNTH),"^",IBPIECE)=$P(^TMP("MNTH",$J,IBDIVNM,IBMNTH),"^",IBPIECE)+1
S $P(^TMP("DTOT",$J,IBDIVNM),"^",IBPIECE)=$P(^TMP("DTOT",$J,IBDIVNM),"^",IBPIECE)+1
S $P(^TMP("GTOT",$J),"^",IBPIECE)=$P(^TMP("GTOT",$J),"^",IBPIECE)+1
Q
PROC ; -- Check to see if there is at least one procedure for the encounter.
N IBCNT S IBCNT=0
K IBXY
S IBDDT1=$P(IBDDT,"."),IBI=IBDDT1-.000001
F S IBI=$O(^SDV("C",IBDFN,IBI)) Q:'IBI!(IBI>(IBDDT1+.25)) D
.S IBCS=0 F S IBCS=$O(^SDV(IBI,"CS",IBCS)) Q:'IBCS I $D(^SDV(IBI,"CS",IBCS,0)) I $P(^SDV(IBI,"CS",IBCS,0),"^",8)=IBIFN,$D(^SDV(IBI,"CS",IBCS,"PR")) S IBPR=^("PR") D Q:$D(IBXY)
..F IBJ=1:1:5 I $P(IBPR,"^",IBJ) S IBCNT=IBCNT+1,IBXY(IBCNT)=$P(IBPR,"^",IBJ)_"^"_IBI Q:$D(IBXY(IBCNT))
Q
;
IBDFOSG4 ;ALB/MAF/AAS - NUMBER OF ENCOUNTERS WITH CPT'S AND DX'S CONT. ; 3/18/96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
START ; -- Loop thru MONTHS
+1 NEW IBQUIT
+2 SET IBQUIT=0
+3 SET ^TMP("GTOT",$JOB)="0^0^0"
BLD ; -- scan ENCOUNTERS
+1 FOR IBDDT=IBDFBEG:0
SET IBDDT=$ORDER(^SCE("B",IBDDT))
IF 'IBDDT!($PIECE(IBDDT,".",1)>IBDFEND)
QUIT
Begin DoDot:1
+2 FOR IBIFN=0:0
SET IBIFN=$ORDER(^SCE("B",IBDDT,IBIFN))
IF 'IBIFN
QUIT
SET IBNODE=$GET(^SCE(IBIFN,0))
Begin DoDot:2
+3 ;division
SET IBDIV=$PIECE(IBNODE,"^",11)
+4 SET IBDIVNM=$PIECE($$SITE^VASITE(,+IBDIV),"^",3)
+5 IF VAUTD=0
IF '$DATA(VAUTD(+IBDIV))
QUIT
+6 ;patient
SET IBDFN=$PIECE(IBNODE,"^",2)
+7 ;stop code
SET IBSTOP=$PIECE(IBNODE,"^",3)
+8 ;clinic
SET IBCLIN=$PIECE(IBNODE,"^",4)
+9 ;parent
SET IBPARNT=$PIECE(IBNODE,"^",6)
+10 ;process
SET IBPROC=$PIECE(IBNODE,"^",8)
+11 ;number of month
SET IBMNTH=$EXTRACT($PIECE(IBNODE,"^"),1,3)_$EXTRACT($PIECE(IBNODE,"^"),4,5)
+12 IF 'IBDFN
QUIT
+13 DO PROC
IF $DATA(IBXY)
SET IBPIECE=2
DO SET
+14 DO SET^SDCO4(IBIFN)
IF $DATA(SDDXY)
SET IBPIECE=3
DO SET
+15 QUIT
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
+18 ;
SET ; -- Set totals
+1 IF '$DATA(^TMP("DTOT",$JOB,IBDIVNM))
SET ^TMP("DTOT",$JOB,IBDIVNM)="0^0^0"
+2 IF '$DATA(^TMP("MNTH",$JOB,IBDIVNM,IBMNTH))
SET ^TMP("MNTH",$JOB,IBDIVNM,IBMNTH)="0^0^0"
+3 SET $PIECE(^TMP("MNTH",$JOB,IBDIVNM,IBMNTH),"^",IBPIECE)=$PIECE(^TMP("MNTH",$JOB,IBDIVNM,IBMNTH),"^",IBPIECE)+1
+4 SET $PIECE(^TMP("DTOT",$JOB,IBDIVNM),"^",IBPIECE)=$PIECE(^TMP("DTOT",$JOB,IBDIVNM),"^",IBPIECE)+1
+5 SET $PIECE(^TMP("GTOT",$JOB),"^",IBPIECE)=$PIECE(^TMP("GTOT",$JOB),"^",IBPIECE)+1
+6 QUIT
PROC ; -- Check to see if there is at least one procedure for the encounter.
+1 NEW IBCNT
SET IBCNT=0
+2 KILL IBXY
+3 SET IBDDT1=$PIECE(IBDDT,".")
SET IBI=IBDDT1-.000001
+4 FOR
SET IBI=$ORDER(^SDV("C",IBDFN,IBI))
IF 'IBI!(IBI>(IBDDT1+.25))
QUIT
Begin DoDot:1
+5 SET IBCS=0
FOR
SET IBCS=$ORDER(^SDV(IBI,"CS",IBCS))
IF 'IBCS
QUIT
IF $DATA(^SDV(IBI,"CS",IBCS,0))
IF $PIECE(^SDV(IBI,"CS",IBCS,0),"^",8)=IBIFN
IF $DATA(^SDV(IBI,"CS",IBCS,"PR"))
SET IBPR=^("PR")
Begin DoDot:2
+6 FOR IBJ=1:1:5
IF $PIECE(IBPR,"^",IBJ)
SET IBCNT=IBCNT+1
SET IBXY(IBCNT)=$PIECE(IBPR,"^",IBJ)_"^"_IBI
IF $DATA(IBXY(IBCNT))
QUIT
End DoDot:2
IF $DATA(IBXY)
QUIT
End DoDot:1
+7 QUIT
+8 ;
