source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRETP.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: 6.0 KB
Line 
1IBCRETP ;LL/ELZ - RATES: TRANSFER PRICING CM FAST ENTER/EDIT ; 24-AUG-1999
2 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ENTER ; OPTION: Transfer Pricing rates fast enter - this requires billing
6 ; rate names are not changed. Will set up charge sets if not defined.
7 ;
8 N DIR,DIRUT,DTOUT,DUOUT,X,Y,IBARR,IBRATE,IBEFDT,IBRVCD,IBCS,IBA
9 W @IOF W !!,?10,"Fast Enter of Transfer Pricing Rates",!!
10 ;
11 S DIR(0)="SO^I:Inpatient;O:Outpatient",DIR("A")="Enter which rates" D ^DIR K DIR
12 S IBRATE=$S(Y="I":"1^TP INPATIENT",Y="O":"2^TP OUTPATIENT",1:"") Q:'IBRATE
13 ;
14 S IBEFDT=$$GETDT^IBCRU1() I IBEFDT'?7N Q
15 ;
16 S IBCS=$$FAC(IBRATE)
17 D EDITCI(IBCS,IBEFDT)
18 Q
19 ;
20FAC(TYPE) ; ask facility, create charge sets and billing region if not defined, return chargeset
21 N DIC,X,Y,DTOUT,DUOUT,IBFAC,IBCS,IBRG
22 ;
23 S DIC="^DIC(4,",DIC(0)="AEMNQ" D ^DIC Q:Y<1 0 S IBFAC=Y
24 ;
25 S IBCS=$$TPCS^IBCRU7(TYPE,+IBFAC) Q:IBCS IBCS
26 ;
27 ; add billing region and charge set to charge master
28 S IBRG=$$RG(IBFAC) Q:'IBRG 0
29 S IBCS=$$ACS(TYPE,IBRG,IBFAC)
30 Q IBCS
31 ;
32RG(INST) ; add a new Billing Region for Transfer pricing (363.31)
33 ; input institution 0 by ref and institution pointer
34 ; returns billing region IFN ^ name
35 N IBNAME,IBRG,X,Y,DLAYGO,DIC,DA,DTOUT,DUOUT,MSG,D0
36 I $G(INST)="" Q 0
37 ;
38 F X=0,1,3,99 S INST(X)=$G(^DIC(4,+INST,X))
39 S IBNAME=$$NNT^XUAF4(+INST)
40 S IBNAME="TP "_$S($P(IBNAME,"^",3)="VISN":$P(IBNAME,"^"),1:$P(INST(99),"^")_" "_$P(INST(1),"^",3))_$S($P(INST(0),"^",2)&($P(IBNAME,"^",3)'="VISN"):", "_$P($G(^DIC(5,$P(INST(0),"^",2),0)),"^",2),1:"")
41 S IBRG=$O(^IBE(363.31,"B",IBNAME,0)) I IBRG Q IBRG_"^"_IBNAME
42 ;
43 K D0 S DLAYGO=363.31,DIC="^IBE(363.31,",DIC(0)="L",X=$E(IBNAME,1,30) D FILE^DICN I Y<1 Q 0
44 S IBRG=Y D MSG(" Added Billing Region "_$P(IBRG,"^",2))
45 ;
46 K DA S DIC(0)="L",DA(1)=+IBRG,DIC=DIC_DA(1)_",21,",X=+INST D FILE^DICN
47 D MSG(" with"_$S(Y>0:"",1:"OUT")_" Institution "_$P(INST(0),"^"))
48 ;
49 D MSGP Q IBRG
50 ;
51ACS(RATE,RG,FAC) ; find or add charge set
52 ; returns IFN of new charge set, 0 otherwise, input is in internal^external format
53 N IBOK,IBNAME,IBEVENT,IBFN,IBBR,IBBE,IBJ,DD,DO,DLAYDO,DINUM,DIC,DA,X,Y,DR,DIE,IBA,IBCSN,MSG S IBOK=1
54 S RATE=$G(RATE),RG=$G(RG),FAC=$G(FAC) I RATE="" G ACSQ
55 ;
56 S IBNAME="TP-"_$S((+RATE)=1:"INPT ",1:"OPT ")_$S($E($P(FAC,"^",2),1,5)="VISN ":$P(FAC,"^",2),1:+FAC)
57 S IBEVENT=$S(RATE[" I":"INPATIENT DRG",1:"PROCEDURE")
58 S IBFN=$O(^IBE(363.1,"B",$E(IBNAME,1,30),0)) I +IBFN S IBOK=0 D MSG(" *** Charge Set "_$E(IBNAME,1,30)_" found")
59 S IBBR=$O(^IBE(363.3,"B",$P(RATE,"^",2),0)) I 'IBBR S IBOK=0 D MSG(" *** Error: "_RATE_" Billing Rate does not exist")
60 S IBBE=$$MCCRUTL(IBEVENT,14) I 'IBBE S IBOK=0 D MSG(" *** Error: "_IBEVENT_" Billable Event undefined")
61 I '$D(^IBE(363.3,+RG)) S IBOK=0 D MSG(" *** Error: "_$P($E(RG,1,30),"^",2)_" Billing Region does not exist")
62 I '$G(IBOK) G ACSQ
63 ;
64 F IBJ=1:1 S IBFN=$G(^IBE(363.1,IBJ,0)) I IBFN="" S DINUM=IBJ Q
65 ;
66 K DD,DO S DLAYGO=363.1,DIC="^IBE(363.1,",DIC(0)="L",X=$E(IBNAME,1,30) D FILE^DICN K DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
67 S IBFN=+Y,IBCSN=$P(Y,U,2)
68 ;
69 S DR=".02////"_IBBR_";.03////"_IBBE_";.07////"_(+RG)
70 S DIE="^IBE(363.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
71 S IBA(1)=" "_$E(IBNAME,1,30)_" Charge Set "_$S('$G(IBFN):"NOT ",1:"")_"added"
72 ;
73ACSQ D MSGP
74 Q +$G(IBFN)
75 ;
76MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
77 N IBX,IBY S IBY=""
78 I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
79 Q IBY
80 ;
81MSG(X) ; add message to end of message list, reserves IBA(1) for primary message
82 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
83 S IBA(IBX)=$G(X)
84 Q
85MSGP ; print error messages in IBA
86 N IBX S IBX="" F S IBX=$O(IBA(IBX)) Q:'IBX W !,IBA(IBX)
87 Q
88 ;
89EDITCI(IBCSFN,IBDT) ; Enter/Edit Charge Items
90 N IBCS0,IBBR0,IBBRFN,IBITEM,IBBRBI,IBCIFN,IBX,DIE,DR,DA,X,Y
91 ;
92CS I '$G(IBCSFN) S IBCSFN=+$$GETCS^IBCRU1 Q:IBCSFN'>0
93 D DISPCS^IBCRU7(+IBCSFN)
94 ;
95 S IBCS0=$G(^IBE(363.1,+IBCSFN,0)),IBBRFN=$P(IBCS0,U,2)
96 S IBBR0=$G(^IBE(363.3,+IBBRFN,0)),IBBRBI=$P(IBBR0,U,4)
97 W !!,"Enter/edit a billable item (",$$BITM(IBBRBI),") for Charge Set ",$P(IBCS0,U,1)
98 ;
99CI W ! S IBITEM=$$GETITEM^IBCRU1(IBCSFN,"",1) I +IBITEM<1 Q
100 I '$$ITFILE^IBCRU2(IBBRBI,+IBITEM) W !!,$$BITM(IBBRBI)," ",$P(IBITEM,U,2)," CURRENTLY INACTIVE",!
101 ;
102EF D DISPCI^IBCRU5(+IBCSFN,+IBITEM)
103 I IBDT<1 S IBDT="" W " ... no change" G CI
104 D SCRNDSPL
105 ;
106 S IBCIFN=$$FINDCI(+IBCSFN,+IBITEM,IBDT) I IBCIFN<0 G EF
107 ;
108 I IBCIFN>0 W !,?50,"Editing Charge Item!"
109 ;
110 I 'IBCIFN D I 'IBCIFN W !!,"A charge can not be added for this item!",! Q
111 . S IBCIFN=$$ADDCI^IBCREF(+IBCSFN,+IBITEM,IBDT) W !,?50,"Adding a new Charge Item!"
112 ;
113 S DR=$$DR01(+$P(IBITEM,U,4))_";.03;.04;.05;"
114 ;
115 I $P(IBITEM,U,4)=81 S DR=DR_".07"
116 ;
117DIE S DIDEL=363.2,DIE="^IBA(363.2,",DA=+IBCIFN D ^DIE K DIE,DR,X,DIDEL
118 ;
119 I $D(DA),$D(Y)=0 S IBX=$$RQCI^IBCREU1(+IBCIFN) I +IBX
120 D DISPCSL^IBCRU7(+IBCSFN)
121 G CI
122 Q
123BITM(X) ; return external form of billable item
124 S X=+$G(X) S X=$$EXPAND^IBCRU1(363.3,.04,X)
125 Q X
126FINDCI(IBCSFN,IBITEM,IBDT) ; find item to edit returns CIIFN or 0 (new) or -1 (error)
127 ;
128 N IBY,IBI,IBCNT,DIR,X,Y,IBARR S IBY=-1
129 S IBI=$O(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,0)) I 'IBI S IBY=0 G FCQ ; none found
130 ;
131 S (IBI,IBCNT)=0 F S IBI=$O(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,+IBI)) Q:'IBI D
132 . S IBCNT=IBCNT+1,IBARR(IBCNT)=IBI D DISPCIL^IBCRU5(IBI,IBCNT)
133 I +IBCNT S DIR(0)="NO^1:"_IBCNT D ^DIR I Y>0 S IBY=$G(IBARR(Y))
134 I '$D(DTOUT),'$D(DUOUT),IBY<1 S DIR(0)="Y",DIR("A")="Add a new Charge Item? " S DIR("B")="Y" D ^DIR I Y=1 S IBY=0
135FCQ Q IBY
136 ;
137DR01(FILE) ; return DR string for editing the .01 field of charge item
138 N IBX S IBX=""
139 I +$G(FILE) S IBX="S DIC(""V"")=""I +Y(0)="_+FILE_""";.01;K DIC(""V"")"
140 Q IBX
141 ;
142SCRNDSPL ; if this edit is called from the screen return the items and dates edited so screen can be
143 ; redisplayed with the new/edited items
144 I $D(IBSRNITM) S IBSRNITM=IBITEM
145 I $D(IBSRNBDT),IBSRNBDT>IBDT S IBSRNBDT=IBDT
146 I $D(IBSRNEDT),+IBSRNEDT,IBSRNEDT<IBDT S IBSRNEDT=IBDT
147 Q
Note: See TracBrowser for help on using the repository browser.