- 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 ;
