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

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.5 KB
Line 
1IBCROIP ;ALB/ARH - RATES: REPORTS CHARGE ITEM: PROCEDURES ; 12/01/04
2 ;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ; OPTION ENTRY POINT: Charge Item report for Procedures Only - get parameters then run the report
6 N RATES,DIVS,CPTS,IBBDT,IBEDT,IBCS,IBCS0,IBSUB,IBQUIT,IBSCRPT
7 ;
8 W !!,"Procedure Charge Report: Print charges for selected CPT procedures.",!
9 ;
10 D SELRATE(.RATES) Q:'RATES ; get billing rates to include
11 D SELDIVS(.DIVS) Q:DIVS<0 ; get divisions
12 D SELCPTS(.CPTS) Q:'CPTS ; get list of CPT codes
13 ;
14 S IBBDT=$$GETDT^IBCRU1(DT,"Charges effective beginning on") Q:IBBDT'?7N
15 S IBEDT=$$GETDT^IBCRU1(DT,"Charges effective ending on") Q:IBEDT'?7N
16 ;
17 S IBQUIT=0 D DEV I IBQUIT G EXIT
18 ;
19RPT ; find, save, and print Charge Item report - entry for tasked jobs DBIA #2815
20 ;
21 K ^TMP($J,"IBCROI") S IBSCRPT="IBCROI"
22 ;
23 S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
24 . S IBCS0=$G(^IBE(363.1,IBCS,0))
25 . ;
26 . I '$D(RATES(+$P(IBCS0,U,2))) Q
27 . I DIVS'=1,+$P(IBCS0,U,7) I '$$CHKDV(+$P(IBCS0,U,7),.DIVS) Q
28 . ;
29 . S IBSUB=+$P(IBCS0,U,4)_U_$P(IBCS0,U,1) ; sort by CT and charge set name
30 . ;
31 . D GET
32 ;
33 D PRINT^IBCROI
34 ;
35EXIT D EXIT^IBCROI
36 Q
37 ;
38 ;
39GET ; get charge items for selected procedures
40 N IBCPTS,IBC1,IBC2,IBCFIRST,IBCLAST,IBCNEXT,IBCIFN
41 ;
42 S IBCPTS="" F S IBCPTS=$O(CPTS(IBCPTS)) Q:IBCPTS="" D
43 . I IBCPTS'?5UN1"-"5UN Q
44 . S IBC1=$P(IBCPTS,"-",1),IBCFIRST=$O(^ICPT("B",IBC1),-1)
45 . S IBC2=$P(IBCPTS,"-",2),IBCLAST=$O(^ICPT("B",IBC2))
46 . ;
47 . S IBCNEXT=IBCFIRST F S IBCNEXT=$O(^ICPT("B",IBCNEXT)) Q:(IBCNEXT="")!(IBCNEXT=IBCLAST) D
48 .. S IBCIFN=$O(^ICPT("B",IBCNEXT,0))
49 .. ;
50 .. D SRCHITM^IBCROI1(IBCS,IBSUB,3,IBBDT,IBEDT,IBCIFN)
51 . ;
52 . D TMPHDR^IBCROI1(IBSCRPT,IBSUB,0,"Procedure Charges","1^1",IBBDT,IBEDT)
53 Q
54 ;
55CHKDV(RG,DIVS) ; check if Region contains a selected division (where DIVS is array of divisions)
56 N IBDV,IBSEL S IBSEL=0
57 I +$O(^IBE(363.31,+$G(RG),11,"B",0)) S IBDV=0 F S IBDV=$O(DIVS(IBDV)) Q:'IBDV D Q:+IBSEL
58 . I +$O(^IBE(363.31,RG,11,"B",IBDV,0)) S IBSEL=1
59 Q IBSEL
60 ;
61SELRATE(RATES) ; get rates to review, RATES(ptr to 363.3)=Billing Rate Name returned, or RATES=0 if none selected
62 N IBN,IBX,IBY,IBCNT,IBDFLT,IBARR,DIR,DIRUT,DTOUT,DUOUT,X,Y K RATES S RATES=0
63 ;
64 S IBN="" F S IBN=$O(^IBE(363.3,"B",IBN)) Q:IBN="" D
65 . S IBX=0 F S IBX=$O(^IBE(363.3,"B",IBN,IBX)) Q:'IBX D
66 .. S IBY=$G(^IBE(363.3,IBX,0)) I $P(IBY,U,4)'=2 Q
67 .. S IBCNT=$G(IBCNT)+1
68 .. ;
69 .. I $E(IBY,1,3)="RC " S IBDFLT=$G(IBDFLT)_IBCNT_","
70 .. S IBARR(IBCNT)=IBX_U_IBN,IBARR=IBCNT
71 ;
72 W !,"Select Charge Billing Rates:"
73 S IBCNT=0 F S IBCNT=$O(IBARR(IBCNT)) Q:'IBCNT W !,?10,IBCNT," - ",$P(IBARR(IBCNT),U,2)
74 ;
75 S DIR(0)="LO^1:"_IBARR_":0",DIR("A")="Charge Rates",DIR("B")=IBDFLT D ^DIR Q:$$QUIT
76 ;
77 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)
78 ;
79 Q
80 ;
81SELDIVS(VAUTD) ; Issue prompt for Division (ALL: VAUTD=1, SELECT: VAUTD=0, VAUTD(DV ptr)=DV Name, ELSE: VAUTD=-1)
82 N Y D PSDR^IBODIV I Y<0 K VAUTD S VAUTD=-1
83 Q
84 ;
85SELCPTS(CPTS) ; Select CPT Codes, returned in array ranges separated by dash, external form, or CPTS=0 if none selected
86 ; will only allow ranges with matching first character because of length
87 N IBI,IBCOD,IBCOD1,IBCOD2,DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y K CPTS S CPTS=0
88 ;
89 S DIR("?")="Enter a CPT/HCPCS code or range of codes separated by a dash"
90 S DIR("A")="Select CPT/HPCS Codes",DIR(0)="FO^^"
91 ;
92 F IBI=1:1 D ^DIR Q:$$QUIT D
93 . S IBCOD=$$UP^XLFSTR(Y),IBCOD1=$P(IBCOD,"-",1),IBCOD2=$P(IBCOD,"-",2)
94 . ;
95 . I IBCOD["-" S IBCOD1=$$LJ^XLFSTR(IBCOD1,5,0),IBCOD2=$$LJ^XLFSTR(IBCOD2,5,0)
96 . I IBCOD'["-" S IBCOD1=$P($$CPTDIC(IBCOD),U,2),IBCOD2=IBCOD1 I IBCOD1="" W ?36,"??" Q
97 . ;
98 . I (IBCOD1'?5UN)!(IBCOD2'?5UN) W ?36,"??" Q
99 . I IBCOD1'=IBCOD2,IBCOD2']IBCOD1 W ?36,IBCOD1,"-",IBCOD2," Invalid Range" Q
100 . I $E(IBCOD1,1)'=$E(IBCOD2,1) W ?36,"Range too large, first character must match" Q
101 . ;
102 . S IBCOD=IBCOD1_"-"_IBCOD2 S CPTS=$G(CPTS)+1,CPTS(IBCOD)=""
103 ;
104 Q
105 ;
106CPTDIC(CODE) ; inquiry on CPT code, returns null or 'internal^external'
107 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
108 Q IBX
109 ;
110 ;
111QUIT() N IBX S IBX=0 I ($G(Y)="")!($D(DIRUT))!($D(DUOUT))!($D(DTOUT)) S IBX=1
112 Q IBX
113 ;
114DEV ; get device
115 S IBQUIT=0 S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS I POP S IBQUIT=1 Q
116 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
117 Q
Note: See TracBrowser for help on using the repository browser.