IBOCNC1 ;ALB/ARH - CPT USAGE IN CLINICS (SEARCH); 1/23/92
;;Version 2.0 ; INTEGRATED BILLING ;; 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 choosen, 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 choosen collect counts on CPTs used and save in sorted tmp file
S IBB=IBBDT-.001,IBE=IBEDT+.3,IBQ=0
F S IBB=$O(^SDV("AP",IBB)) Q:IBB=""!(IBB>IBE)!IBQ D S IBQ=$$STOP
. S IBX="" F S IBX=$O(^SDV(IBB,"CS",IBX)) Q:IBX'?1N.N D
.. S IBCLN=$P($G(^SDV(IBB,"CS",IBX,0)),"^",3) Q:IBCLN=""!('$D(^SC(+IBCLN,0)))
.. I $D(^TMP("IBCU",$J,"C",IBCLN)) S IBLN=$G(^SDV(IBB,"CS",IBX,"PR")) Q:IBLN="" D
... S IBCPT="" F IBI=1:1 S IBCPT=$P(IBLN,"^",IBI) Q:IBCPT=""!('$D(^ICPT(+IBCPT,0))) D
.... I IBSRT S ^TMP("IBCU",$J,IBCPT)=$G(^TMP("IBCU",$J,IBCPT))+1,^TMP("IBCU",$J)=$G(^TMP("IBCU",$J))+1 Q
.... S IBCLNN=$P($G(^SC(IBCLN,0)),"^",1),^TMP("IBCU",$J,IBCLNN,"N")=IBCLN
.... S ^TMP("IBCU",$J,IBCLNN)=$G(^TMP("IBCU",$J,IBCLNN))+1
.... S ^TMP("IBCU",$J,IBCLNN,IBCPT)=$G(^TMP("IBCU",$J,IBCLNN,IBCPT))+1
K IBB,IBE,IBX,IBCLN,IBCLNN,IBCPT,IBLN,IBI,^TMP("IBCU",$J,"C")
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 $D(^ICPT(+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
;
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)
IBOCNC1 ;ALB/ARH - CPT USAGE IN CLINICS (SEARCH); 1/23/92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 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 choosen, 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 choosen collect counts on CPTs used and save in sorted tmp file
+1 SET IBB=IBBDT-.001
SET IBE=IBEDT+.3
SET IBQ=0
+2 FOR
SET IBB=$ORDER(^SDV("AP",IBB))
IF IBB=""!(IBB>IBE)!IBQ
QUIT
Begin DoDot:1
+3 SET IBX=""
FOR
SET IBX=$ORDER(^SDV(IBB,"CS",IBX))
IF IBX'?1N.N
QUIT
Begin DoDot:2
+4 SET IBCLN=$PIECE($GET(^SDV(IBB,"CS",IBX,0)),"^",3)
IF IBCLN=""!('$DATA(^SC(+IBCLN,0)))
QUIT
+5 IF $DATA(^TMP("IBCU",$JOB,"C",IBCLN))
SET IBLN=$GET(^SDV(IBB,"CS",IBX,"PR"))
IF IBLN=""
QUIT
Begin DoDot:3
+6 SET IBCPT=""
FOR IBI=1:1
SET IBCPT=$PIECE(IBLN,"^",IBI)
IF IBCPT=""!('$DATA(^ICPT(+IBCPT,0)))
QUIT
Begin DoDot:4
+7 IF IBSRT
SET ^TMP("IBCU",$JOB,IBCPT)=$GET(^TMP("IBCU",$JOB,IBCPT))+1
SET ^TMP("IBCU",$JOB)=$GET(^TMP("IBCU",$JOB))+1
QUIT
+8 SET IBCLNN=$PIECE($GET(^SC(IBCLN,0)),"^",1)
SET ^TMP("IBCU",$JOB,IBCLNN,"N")=IBCLN
+9 SET ^TMP("IBCU",$JOB,IBCLNN)=$GET(^TMP("IBCU",$JOB,IBCLNN))+1
+10 SET ^TMP("IBCU",$JOB,IBCLNN,IBCPT)=$GET(^TMP("IBCU",$JOB,IBCLNN,IBCPT))+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
SET IBQ=$$STOP
+11 KILL IBB,IBE,IBX,IBCLN,IBCLNN,IBCPT,IBLN,IBI,^TMP("IBCU",$JOB,"C")
+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 $DATA(^ICPT(+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 ;
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)
