source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCROIP.m@ 1470

IBCROIP ;ALB/ARH - RATES: REPORTS CHARGE ITEM: PROCEDURES ; 12/01/04
 ;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
EN ; OPTION ENTRY POINT:  Charge Item report for Procedures Only - get parameters then run the report
 N RATES,DIVS,CPTS,IBBDT,IBEDT,IBCS,IBCS0,IBSUB,IBQUIT,IBSCRPT
 ;
 W !!,"Procedure Charge Report: Print charges for selected CPT procedures.",!
 ;
 D SELRATE(.RATES) Q:'RATES  ;  get billing rates to include
 D SELDIVS(.DIVS) Q:DIVS<0  ;   get divisions
 D SELCPTS(.CPTS) Q:'CPTS  ;    get list of CPT codes
 ;
 S IBBDT=$$GETDT^IBCRU1(DT,"Charges effective beginning on") Q:IBBDT'?7N
 S IBEDT=$$GETDT^IBCRU1(DT,"Charges effective ending on") Q:IBEDT'?7N
 ;
 S IBQUIT=0 D DEV I IBQUIT G EXIT
 ;
RPT ; find, save, and print Charge Item report - entry for tasked jobs  DBIA #2815
 ;
 K ^TMP($J,"IBCROI") S IBSCRPT="IBCROI"
 ;
 S IBCS=0 F  S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS  D
 . S IBCS0=$G(^IBE(363.1,IBCS,0))
 . ;
 . I '$D(RATES(+$P(IBCS0,U,2))) Q
 . I DIVS'=1,+$P(IBCS0,U,7) I '$$CHKDV(+$P(IBCS0,U,7),.DIVS) Q
 . ;
 . S IBSUB=+$P(IBCS0,U,4)_U_$P(IBCS0,U,1) ; sort by CT and charge set name
 . ;
 . D GET
 ;
 D PRINT^IBCROI
 ;
EXIT D EXIT^IBCROI
 Q
 ;
 ;
GET ; get charge items for selected procedures
 N IBCPTS,IBC1,IBC2,IBCFIRST,IBCLAST,IBCNEXT,IBCIFN
 ;
 S IBCPTS="" F  S IBCPTS=$O(CPTS(IBCPTS)) Q:IBCPTS=""  D
 . I IBCPTS'?5UN1"-"5UN Q
 . S IBC1=$P(IBCPTS,"-",1),IBCFIRST=$O(^ICPT("B",IBC1),-1)
 . S IBC2=$P(IBCPTS,"-",2),IBCLAST=$O(^ICPT("B",IBC2))
 . ;
 . S IBCNEXT=IBCFIRST F  S IBCNEXT=$O(^ICPT("B",IBCNEXT)) Q:(IBCNEXT="")!(IBCNEXT=IBCLAST)  D
 .. S IBCIFN=$O(^ICPT("B",IBCNEXT,0))
 .. ;
 .. D SRCHITM^IBCROI1(IBCS,IBSUB,3,IBBDT,IBEDT,IBCIFN)
 . ;
 . D TMPHDR^IBCROI1(IBSCRPT,IBSUB,0,"Procedure Charges","1^1",IBBDT,IBEDT)
 Q
 ;
CHKDV(RG,DIVS) ; check if Region contains a selected division (where DIVS is array of divisions)
 N IBDV,IBSEL S IBSEL=0
 I +$O(^IBE(363.31,+$G(RG),11,"B",0)) S IBDV=0 F  S IBDV=$O(DIVS(IBDV)) Q:'IBDV  D  Q:+IBSEL
 . I +$O(^IBE(363.31,RG,11,"B",IBDV,0)) S IBSEL=1
 Q IBSEL
 ;
SELRATE(RATES) ; get rates to review, RATES(ptr to 363.3)=Billing Rate Name returned, or RATES=0 if none selected
 N IBN,IBX,IBY,IBCNT,IBDFLT,IBARR,DIR,DIRUT,DTOUT,DUOUT,X,Y K RATES S RATES=0
 ;
 S IBN="" F  S IBN=$O(^IBE(363.3,"B",IBN)) Q:IBN=""  D
 . S IBX=0 F  S IBX=$O(^IBE(363.3,"B",IBN,IBX)) Q:'IBX  D
 .. S IBY=$G(^IBE(363.3,IBX,0)) I $P(IBY,U,4)'=2 Q
 .. S IBCNT=$G(IBCNT)+1
 .. ;
 .. I $E(IBY,1,3)="RC " S IBDFLT=$G(IBDFLT)_IBCNT_","
 .. S IBARR(IBCNT)=IBX_U_IBN,IBARR=IBCNT
 ;
 W !,"Select Charge Billing Rates:"
 S IBCNT=0  F  S IBCNT=$O(IBARR(IBCNT)) Q:'IBCNT  W !,?10,IBCNT," - ",$P(IBARR(IBCNT),U,2)
 ;
 S DIR(0)="LO^1:"_IBARR_":0",DIR("A")="Charge Rates",DIR("B")=IBDFLT D ^DIR Q:$$QUIT
 ;
 F IBX=1:1:20 S IBCNT=$P(Y,",",IBX) Q:'IBCNT  S IBY=IBARR(IBCNT),RATES=$G(RATES)+1,RATES(+IBY)=$P(IBY,U,2)
 ;
 Q
 ;
SELDIVS(VAUTD) ; Issue prompt for Division (ALL: VAUTD=1,  SELECT: VAUTD=0, VAUTD(DV ptr)=DV Name, ELSE: VAUTD=-1)
 N Y D PSDR^IBODIV I Y<0 K VAUTD S VAUTD=-1
 Q
 ;
SELCPTS(CPTS) ; Select CPT Codes, returned in array ranges separated by dash, external form, or CPTS=0 if none selected
 ; will only allow ranges with matching first character because of length
 N IBI,IBCOD,IBCOD1,IBCOD2,DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y K CPTS S CPTS=0
 ;
 S DIR("?")="Enter a CPT/HCPCS code or range of codes separated by a dash"
 S DIR("A")="Select CPT/HPCS Codes",DIR(0)="FO^^"
 ;
 F IBI=1:1 D ^DIR Q:$$QUIT  D
 . S IBCOD=$$UP^XLFSTR(Y),IBCOD1=$P(IBCOD,"-",1),IBCOD2=$P(IBCOD,"-",2)
 . ;
 . I IBCOD["-" S IBCOD1=$$LJ^XLFSTR(IBCOD1,5,0),IBCOD2=$$LJ^XLFSTR(IBCOD2,5,0)
 . I IBCOD'["-" S IBCOD1=$P($$CPTDIC(IBCOD),U,2),IBCOD2=IBCOD1 I IBCOD1="" W ?36,"??" Q
 . ;
 . I (IBCOD1'?5UN)!(IBCOD2'?5UN) W ?36,"??" Q
 . I IBCOD1'=IBCOD2,IBCOD2']IBCOD1 W ?36,IBCOD1,"-",IBCOD2," Invalid Range" Q
 . I $E(IBCOD1,1)'=$E(IBCOD2,1) W ?36,"Range too large, first character must match" Q
 . ;
 . S IBCOD=IBCOD1_"-"_IBCOD2 S CPTS=$G(CPTS)+1,CPTS(IBCOD)=""
 ;
 Q
 ;
CPTDIC(CODE) ; inquiry on CPT code, returns null or 'internal^external'
 N IBX,DIC,DUOUT,DTOUT,I,X,Y S IBX="" I $G(CODE)'="" S X=CODE,DIC="^ICPT(",DIC(0)="EM" D ^DIC I Y>1 S IBX=Y
 Q IBX
 ;
 ;
QUIT() N IBX S IBX=0 I ($G(Y)="")!($D(DIRUT))!($D(DUOUT))!($D(DTOUT)) S IBX=1
 Q IBX
 ;
DEV ; get device
 S IBQUIT=0 S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS I POP S IBQUIT=1 Q
 I $D(IO("Q")) S ZTRTN="RPT^IBCROIP",ZTDESC="Charge Procedure Report",ZTSAVE("IB*")="",ZTSAVE("RATES(")="",ZTSAVE("CPTS(")="",ZTSAVE("DIVS(")="",ZTSAVE("DIVS")="" D ^%ZTLOAD K IO("Q") S IBQUIT=1
 Q