- IBOCNC1 ;ALB/ARH - CPT USAGE IN CLINICS (SEARCH); 1/23/92
- ;;2.0;INTEGRATED BILLING;**91,133**;21-MAR-94
- ;
- ;entry pt. for tasked jobs
- FIND ;find, save, and print the data that satisfies the search parameters, save clinic/division names
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOCNC" D T1^%ZOSV ;stop rt clock
- ;S XRTL=$ZU(0),XRTN="IBOCNC-2" D T0^%ZOSV ;start rt clock
- I VAUTC,VAUTD S ^TMP("IBCU",$J,"D","ALL")="",IBPRC(1)="ALL DIVISIONS AND CLINICS"
- S X=0
- I VAUTC,'VAUTD S X=X+1,IBC="",IBPRC(X)="DIVISIONS: ",IBDIV="" F IBI=1:1 S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D
- . S ^TMP("IBCU",$J,"D",IBDIV)=""
- . I ($L(IBPRC(X))+$L(VAUTD(IBDIV))+2)>IOM S X=X+1,IBPRC(X)=" ",IBC=""
- . S IBPRC(X)=IBPRC(X)_IBC_VAUTD(IBDIV),IBC=", "
- I 'VAUTC S X=X+1,IBC="",IBPRC(X)="CLINICS: ",IBCLN="" F IBI=1:1 S IBCLN=$O(VAUTC(IBCLN)) Q:IBCLN="" D
- . S ^TMP("IBCU",$J,"C",IBCLN)=""
- . I ($L(IBPRC(X))+$L(VAUTC(IBCLN))+2)>IOM S X=X+1,IBPRC(X)=" ",IBC=""
- . S IBPRC(X)=IBPRC(X)_IBC_VAUTC(IBCLN),IBC=", "
- K VAUTD,VAUTC,IBC,X
- ;entire divisions were chosen, find all clinics
- I $D(^TMP("IBCU",$J,"D","ALL")) S IBDIV="" F S IBDIV=$O(^DG(40.8,IBDIV)) Q:IBDIV'?1N.N S ^TMP("IBCU",$J,"D",IBDIV)=""
- I $D(^TMP("IBCU",$J,"D")) S IBCLN="" F IBI=1:1 S IBCLN=$O(^SC(IBCLN)) Q:IBCLN'?1N.N D
- . S IBLN=$G(^SC(IBCLN,0)) Q:$P(IBLN,"^",3)'="C"!('$D(^TMP("IBCU",$J,"D",+$P(IBLN,"^",15))))
- . S ^TMP("IBCU",$J,"C",IBCLN)=""
- K IBLN,IBCLN,IBDIV,IBI,^TMP("IBCU",$J,"D")
- ;I $D(XRT0),'$D(^TMP("IBCU",$J,"C")) S:'$D(XRTN) XRTN="IBOCNC" D T1^%ZOSV ;stop rt clock
- Q:'$D(^TMP("IBCU",$J,"C"))
- ;
- SAVE ;for each clinic chosen collect counts on CPTs used and save in sorted tmp file
- N IBVAL,IBCBK,IBFILTER
- S IBVAL("BDT")=IBBDT,IBVAL("EDT")=IBEDT+.3
- ; Must be an encounter for one of the clinics chosen,
- ; only count each visit (in v-file) once
- S IBFILTER=""
- S IBCBK="I '$P(Y0,U,6),$D(^TMP(""IBCU"",$J,""C"",+$P(Y0,U,4))),'$D(^TMP(""VIS"",$J,+$P(Y0,U,5))) S ^TMP(""VIS"",$J,+$P(Y0,U,5))="""" D CKENC^IBOCNC1(Y,Y0,.SDSTOP) S:$G(SDSTOP) IBQ=1"
- S IBQ=0
- K ^TMP("VIS",$J)
- D SCAN^IBSDU("DATE/TIME",.IBVAL,IBFILTER,IBCBK)
- ;
- K IBB,IBE,IBX,IBCLN,IBCLNN,IBCPT,IBLN,IBI,^TMP("IBCU",$J,"C"),^TMP("VIS",$J)
- D:IBSRT BILL
- PRINT I 'IBQ D ^IBOCNC2
- K IBPRC,IBSRT,IBQ,^TMP("IBCU",$J)
- I $D(ZTQUEUED) S ZTREQ="@"
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOCNC" D T1^%ZOSV ;stop rt clock
- Q
- ;
- BILL ;when sorting by CPT, get count on CPT's entered in billing for the date range
- ;count number of CPTs in old format, using event date as procedure date
- Q:IBQ S IBEVDT=IBBDT-.001,IBE=IBEDT+.3
- F S IBEVDT=$O(^DGCR(399,"D",IBEVDT)) Q:IBEVDT=""!(IBEVDT>IBE)!IBQ D S IBQ=$$STOP
- . S IBN="" F S IBN=$O(^DGCR(399,"D",IBEVDT,IBN)) Q:IBN="" D
- .. Q:$P($G(^DGCR(399,IBN,0)),"^",9)'=4!('$D(^DGCR(399,IBN,"C")))!($P($G(^DGCR(399,IBN,0)),"^",13)=7) S IBX=$G(^DGCR(399,IBN,"C"))
- .. F IBI=1,2,3,7,8,9 S IBCPT=$P(IBX,"^",IBI) I $$CPT^ICPTCOD(+IBCPT)>0 S ^TMP("IBCU",$J,+IBCPT,"B")=$G(^TMP("IBCU",$J,+IBCPT,"B"))+1,^TMP("IBCU",$J,"B")=$G(^TMP("IBCU",$J,"B"))+1
- ;count number of CPTs in "CP" multiple using the cross-reference and the correct procedure date
- Q:IBQ S IBPDT=-(IBEDT+.3)
- F S IBPDT=$O(^DGCR(399,"ASD",IBPDT)) Q:IBPDT=""!(-IBPDT<IBBDT)!IBQ D S IBQ=$$STOP
- . S IBCPT="" F S IBCPT=$O(^DGCR(399,"ASD",IBPDT,IBCPT)) Q:IBCPT="" D
- .. S IBN="" F S IBN=$O(^DGCR(399,"ASD",IBPDT,IBCPT,IBN)) Q:IBN="" D
- ... Q:$P($G(^DGCR(399,IBN,0)),U,13)=7
- ... S IBX="" F S IBX=$O(^DGCR(399,"ASD",IBPDT,IBCPT,IBN,IBX)) Q:IBX="" D
- .... S ^TMP("IBCU",$J,+IBCPT,"B")=$G(^TMP("IBCU",$J,+IBCPT,"B"))+1,^TMP("IBCU",$J,"B")=$G(^TMP("IBCU",$J,"B"))+1
- K IBEVDT,IBPDT,IBN,IBE,IBI,IBCPT,IBX
- Q
- ;
- CKENC(IBOE,IBOE0,SDSTOP) ;
- N PARRAY,P,IBZERR,IBQUANTY
- I $$STOP S SDSTOP=1 Q
- D GETCPT^SDOE(IBOE,"PARRAY","IBZERR")
- Q:'$O(PARRAY(0))
- S IBCLN=$P(IBOE0,U,4)
- S P=0 F S P=$O(PARRAY(P)) Q:'P S IBCPT=+PARRAY(P) D
- . S IBQUANTY=$P($G(PARRAY(P)),U,16)
- . I IBSRT S ^TMP("IBCU",$J,IBCPT)=$G(^TMP("IBCU",$J,IBCPT))+IBQUANTY,^TMP("IBCU",$J)=$G(^TMP("IBCU",$J))+IBQUANTY Q
- . S IBCLNN=$P($G(^SC(IBCLN,0)),U),^TMP("IBCU",$J,IBCLNN,"N")=IBCLN
- . S ^TMP("IBCU",$J,IBCLNN)=$G(^TMP("IBCU",$J,IBCLNN))+IBQUANTY
- . S ^TMP("IBCU",$J,IBCLNN,IBCPT)=$G(^TMP("IBCU",$J,IBCLNN,IBCPT))+IBQUANTY
- Q
- ;
- STOP() ;check for user requested stop when queued
- I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !!,"TASK STOPPED BY USER",!!
- Q +$G(ZTSTOP)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOCNC1 4449 printed Feb 18, 2025@23:51:51 Page 2
- IBOCNC1 ;ALB/ARH - CPT USAGE IN CLINICS (SEARCH); 1/23/92
- +1 ;;2.0;INTEGRATED BILLING;**91,133**;21-MAR-94
- +2 ;
- +3 ;entry pt. for tasked jobs
- FIND ;find, save, and print the data that satisfies the search parameters, save clinic/division names
- +1 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOCNC" D T1^%ZOSV ;stop rt clock
- +2 ;S XRTL=$ZU(0),XRTN="IBOCNC-2" D T0^%ZOSV ;start rt clock
- +3 IF VAUTC
- IF VAUTD
- SET ^TMP("IBCU",$JOB,"D","ALL")=""
- SET IBPRC(1)="ALL DIVISIONS AND CLINICS"
- +4 SET X=0
- +5 IF VAUTC
- IF 'VAUTD
- SET X=X+1
- SET IBC=""
- SET IBPRC(X)="DIVISIONS: "
- SET IBDIV=""
- FOR IBI=1:1
- SET IBDIV=$ORDER(VAUTD(IBDIV))
- if IBDIV=""
- QUIT
- Begin DoDot:1
- +6 SET ^TMP("IBCU",$JOB,"D",IBDIV)=""
- +7 IF ($LENGTH(IBPRC(X))+$LENGTH(VAUTD(IBDIV))+2)>IOM
- SET X=X+1
- SET IBPRC(X)=" "
- SET IBC=""
- +8 SET IBPRC(X)=IBPRC(X)_IBC_VAUTD(IBDIV)
- SET IBC=", "
- End DoDot:1
- +9 IF 'VAUTC
- SET X=X+1
- SET IBC=""
- SET IBPRC(X)="CLINICS: "
- SET IBCLN=""
- FOR IBI=1:1
- SET IBCLN=$ORDER(VAUTC(IBCLN))
- if IBCLN=""
- QUIT
- Begin DoDot:1
- +10 SET ^TMP("IBCU",$JOB,"C",IBCLN)=""
- +11 IF ($LENGTH(IBPRC(X))+$LENGTH(VAUTC(IBCLN))+2)>IOM
- SET X=X+1
- SET IBPRC(X)=" "
- SET IBC=""
- +12 SET IBPRC(X)=IBPRC(X)_IBC_VAUTC(IBCLN)
- SET IBC=", "
- End DoDot:1
- +13 KILL VAUTD,VAUTC,IBC,X
- +14 ;entire divisions were chosen, find all clinics
- +15 IF $DATA(^TMP("IBCU",$JOB,"D","ALL"))
- SET IBDIV=""
- FOR
- SET IBDIV=$ORDER(^DG(40.8,IBDIV))
- if IBDIV'?1N.N
- QUIT
- SET ^TMP("IBCU",$JOB,"D",IBDIV)=""
- +16 IF $DATA(^TMP("IBCU",$JOB,"D"))
- SET IBCLN=""
- FOR IBI=1:1
- SET IBCLN=$ORDER(^SC(IBCLN))
- if IBCLN'?1N.N
- QUIT
- Begin DoDot:1
- +17 SET IBLN=$GET(^SC(IBCLN,0))
- if $PIECE(IBLN,"^",3)'="C"!('$DATA(^TMP("IBCU",$JOB,"D",+$PIECE(IBLN,"^",15))))
- QUIT
- +18 SET ^TMP("IBCU",$JOB,"C",IBCLN)=""
- End DoDot:1
- +19 KILL IBLN,IBCLN,IBDIV,IBI,^TMP("IBCU",$JOB,"D")
- +20 ;I $D(XRT0),'$D(^TMP("IBCU",$J,"C")) S:'$D(XRTN) XRTN="IBOCNC" D T1^%ZOSV ;stop rt clock
- +21 if '$DATA(^TMP("IBCU",$JOB,"C"))
- QUIT
- +22 ;
- SAVE ;for each clinic chosen collect counts on CPTs used and save in sorted tmp file
- +1 NEW IBVAL,IBCBK,IBFILTER
- +2 SET IBVAL("BDT")=IBBDT
- SET IBVAL("EDT")=IBEDT+.3
- +3 ; Must be an encounter for one of the clinics chosen,
- +4 ; only count each visit (in v-file) once
- +5 SET IBFILTER=""
- +6 SET IBCBK="I '$P(Y0,U,6),$D(^TMP(""IBCU"",$J,""C"",+$P(Y0,U,4))),'$D(^TMP(""VIS"",$J,+$P(Y0,U,5))) S ^TMP(""VIS"",$J,+$P(Y0,U,5))="""" D CKENC^IBOCNC1(Y,Y0,.SDSTOP) S:$G(SDSTOP) IBQ=1"
- +7 SET IBQ=0
- +8 KILL ^TMP("VIS",$JOB)
- +9 DO SCAN^IBSDU("DATE/TIME",.IBVAL,IBFILTER,IBCBK)
- +10 ;
- +11 KILL IBB,IBE,IBX,IBCLN,IBCLNN,IBCPT,IBLN,IBI,^TMP("IBCU",$JOB,"C"),^TMP("VIS",$JOB)
- +12 if IBSRT
- DO BILL
- PRINT IF 'IBQ
- DO ^IBOCNC2
- +1 KILL IBPRC,IBSRT,IBQ,^TMP("IBCU",$JOB)
- +2 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOCNC" D T1^%ZOSV ;stop rt clock
- +4 QUIT
- +5 ;
- BILL ;when sorting by CPT, get count on CPT's entered in billing for the date range
- +1 ;count number of CPTs in old format, using event date as procedure date
- +2 if IBQ
- QUIT
- SET IBEVDT=IBBDT-.001
- SET IBE=IBEDT+.3
- +3 FOR
- SET IBEVDT=$ORDER(^DGCR(399,"D",IBEVDT))
- if IBEVDT=""!(IBEVDT>IBE)!IBQ
- QUIT
- Begin DoDot:1
- +4 SET IBN=""
- FOR
- SET IBN=$ORDER(^DGCR(399,"D",IBEVDT,IBN))
- if IBN=""
- QUIT
- Begin DoDot:2
- +5 if $PIECE($GET(^DGCR(399,IBN,0)),"^",9)'=4!('$DATA(^DGCR(399,IBN,"C")))!($PIECE($GET(^DGCR(399,IBN,0)),"^",13)=7)
- QUIT
- SET IBX=$GET(^DGCR(399,IBN,"C"))
- +6 FOR IBI=1,2,3,7,8,9
- SET IBCPT=$PIECE(IBX,"^",IBI)
- IF $$CPT^ICPTCOD(+IBCPT)>0
- SET ^TMP("IBCU",$JOB,+IBCPT,"B")=$GET(^TMP("IBCU",$JOB,+IBCPT,"B"))+1
- SET ^TMP("IBCU",$JOB,"B")=$GET(^TMP("IBCU",$JOB,"B"))+1
- End DoDot:2
- End DoDot:1
- SET IBQ=$$STOP
- +7 ;count number of CPTs in "CP" multiple using the cross-reference and the correct procedure date
- +8 if IBQ
- QUIT
- SET IBPDT=-(IBEDT+.3)
- +9 FOR
- SET IBPDT=$ORDER(^DGCR(399,"ASD",IBPDT))
- if IBPDT=""!(-IBPDT<IBBDT)!IBQ
- QUIT
- Begin DoDot:1
- +10 SET IBCPT=""
- FOR
- SET IBCPT=$ORDER(^DGCR(399,"ASD",IBPDT,IBCPT))
- if IBCPT=""
- QUIT
- Begin DoDot:2
- +11 SET IBN=""
- FOR
- SET IBN=$ORDER(^DGCR(399,"ASD",IBPDT,IBCPT,IBN))
- if IBN=""
- QUIT
- Begin DoDot:3
- +12 if $PIECE($GET(^DGCR(399,IBN,0)),U,13)=7
- QUIT
- +13 SET IBX=""
- FOR
- SET IBX=$ORDER(^DGCR(399,"ASD",IBPDT,IBCPT,IBN,IBX))
- if IBX=""
- QUIT
- Begin DoDot:4
- +14 SET ^TMP("IBCU",$JOB,+IBCPT,"B")=$GET(^TMP("IBCU",$JOB,+IBCPT,"B"))+1
- SET ^TMP("IBCU",$JOB,"B")=$GET(^TMP("IBCU",$JOB,"B"))+1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- SET IBQ=$$STOP
- +15 KILL IBEVDT,IBPDT,IBN,IBE,IBI,IBCPT,IBX
- +16 QUIT
- +17 ;
- CKENC(IBOE,IBOE0,SDSTOP) ;
- +1 NEW PARRAY,P,IBZERR,IBQUANTY
- +2 IF $$STOP
- SET SDSTOP=1
- QUIT
- +3 DO GETCPT^SDOE(IBOE,"PARRAY","IBZERR")
- +4 if '$ORDER(PARRAY(0))
- QUIT
- +5 SET IBCLN=$PIECE(IBOE0,U,4)
- +6 SET P=0
- FOR
- SET P=$ORDER(PARRAY(P))
- if 'P
- QUIT
- SET IBCPT=+PARRAY(P)
- Begin DoDot:1
- +7 SET IBQUANTY=$PIECE($GET(PARRAY(P)),U,16)
- +8 IF IBSRT
- SET ^TMP("IBCU",$JOB,IBCPT)=$GET(^TMP("IBCU",$JOB,IBCPT))+IBQUANTY
- SET ^TMP("IBCU",$JOB)=$GET(^TMP("IBCU",$JOB))+IBQUANTY
- QUIT
- +9 SET IBCLNN=$PIECE($GET(^SC(IBCLN,0)),U)
- SET ^TMP("IBCU",$JOB,IBCLNN,"N")=IBCLN
- +10 SET ^TMP("IBCU",$JOB,IBCLNN)=$GET(^TMP("IBCU",$JOB,IBCLNN))+IBQUANTY
- +11 SET ^TMP("IBCU",$JOB,IBCLNN,IBCPT)=$GET(^TMP("IBCU",$JOB,IBCLNN,IBCPT))+IBQUANTY
- End DoDot:1
- +12 QUIT
- +13 ;
- STOP() ;check for user requested stop when queued
- +1 IF $DATA(ZTQUEUED)
- IF $$S^%ZTLOAD
- SET ZTSTOP=1
- KILL ZTREQ
- IF +$GET(IBPGN)
- WRITE !!,"TASK STOPPED BY USER",!!
- +2 QUIT +$GET(ZTSTOP)
