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 Dec 13, 2024@02:25:21 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)
