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