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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1IBCREQ ;ALB/ARH-RATES: CM FAST ENTER/EDIT OPTION ;22-MAY-1996
2 ;;2.0;INTEGRATED BILLING;**52,153,167,187**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ENTER ; OPTION: fast enter Tort or Interagency rates - this option requires charge sets defined as released,
6 ; name not changed and a standard set of charges
7 N DIR,DIRUT,DTOUT,DUOUT,X,Y,IBARR,IBRATE,IBEFDT,IBRVCD
8 W @IOF W !!,?10,"Fast Enter of Tortiously Liable and Interagency Rates",!!
9 ;
10 S DIR(0)="SO^T:Tortiously Liable;I:Interagency",DIR("A")="Enter which rates" D ^DIR K DIR
11 S IBRATE=$S(Y="T":"1^TORTIOUSLY LIABLE",Y="I":"2^INTERAGENCY",1:"") Q:'IBRATE
12 ;
13 S IBEFDT=$$GETDT^IBCRU1() I IBEFDT'?7N Q
14 I +IBRATE=1 S IBRVCD=$$NPFRC Q:'IBRVCD I '$$TORT(IBRATE,IBEFDT,.IBARR,IBRVCD) Q
15 I +IBRATE=2 I '$$IA(IBRATE,IBEFDT,.IBARR) Q
16 ;
17 D DISP(IBRATE,.IBARR) Q:$D(DIRUT)
18 I +IBRATE=2 D SET(IBRATE,.IBARR)
19 E D SET(IBRATE,.IBARR):'$$MT
20 ;
21 I IBRATE=1 D ENR^IBEMTO K IBRUN ; bill MT OPT charges awaiting the new copay rate
22 ;
23 Q
24 ;
25TORT(IBRATE,EFDT,ARR,IBRVCD) ; find the standard charge sets for Tort rates
26 N IBCSN,IBX K ARR S ARR=$G(EFDT),IBRVCD=$G(IBRVCD),IBX=0
27 S ARR(1)="INPATIENT^INPT",ARR(2)="OUTPATIENT VISIT^OPT VISIT",ARR(3)="PRESCRIPTION REFILL^RX REFILL"
28 S ARR(4)="OUTPATIENT DENTAL^OPT DENTAL" ;ARR(5)="MT OUTPATIENT COPAYMENT^MT OPT COPAY"
29 S IBCSN="TL-INPT (INCLUSIVE)" I '$$CS(IBRATE,IBCSN,1,1,"","(All Inclusive)",.ARR) G TORTQ
30 S IBCSN="TL-INPT (NPF)" I '$$CS(IBRATE,IBCSN,1,2,$P(IBRVCD,U,1),"(Room,board)",.ARR) G TORTQ
31 S IBCSN="TL-INPT (NPF)" I '$$CS(IBRATE,IBCSN,1,3,$P(IBRVCD,U,2),"(Ancillary)",.ARR) G TORTQ
32 S IBCSN="TL-INPT (PF)" I '$$CS(IBRATE,IBCSN,1,4,"","(Physician)",.ARR) G TORTQ
33 S IBCSN="TL-OPT VST" I '$$CS(IBRATE,IBCSN,2,1,"","",.ARR) G TORTQ
34 S IBCSN="TL-RX FILL" I '$$CS(IBRATE,IBCSN,3,1,"","",.ARR) G TORTQ
35 S IBCSN="TL-OPT DENTAL" I '$$CS(IBRATE,IBCSN,4,1,"","",.ARR) G TORTQ
36 ;S IBCSN="TL-MT OPT COPAY" I '$$CS(IBRATE,IBCSN,5,1,"","",.ARR) G TORTQ
37 S IBX=1
38TORTQ I 'IBX W !!,"The Fast Enter of rates expects to find the standard rates and sets released",!,"nationally, if these are not found this option can not be used."
39 Q IBX
40 ;
41IA(IBRATE,EFDT,ARR) ; find the standard charge sets for Interagency rates
42 N IBCSN,IBX K ARR S ARR=$G(EFDT),IBX=0
43 S ARR(1)="INPATIENT",ARR(2)="OUTPATIENT VISIT",ARR(3)="PRESCRIPTION REFILL",ARR(4)="OUTPATIENT DENTAL"
44 S ARR(1)="INPATIENT^INPT",ARR(2)="OUTPATIENT VISIT^OPT VISIT",ARR(3)="PRESCRIPTION REFILL^RX REFILL",ARR(4)="OUTPATIENT DENTAL^OPT DENTAL"
45 S IBCSN="IA-INPT" I '$$CS(IBRATE,IBCSN,1,1,"","(All Inclusive)",.ARR) G IAQ
46 S IBCSN="IA-OPT VST" I '$$CS(IBRATE,IBCSN,2,1,"","",.ARR) G IAQ
47 S IBCSN="IA-RX FILL" I '$$CS(IBRATE,IBCSN,3,1,"","",.ARR) G IAQ
48 S IBCSN="IA-OPT DENTAL" I '$$CS(IBRATE,IBCSN,4,1,"","",.ARR) G IAQ
49 S IBX=1
50IAQ I 'IBX W !!,"The Fast Enter of rates expects to find the standard rates and sets released",!,"nationally, if these are not found this option can not be used."
51 Q IBX
52 ;
53CS(IBRATE,IBCSN,TYPE,ITEM,RVCD,DESC,ARR) ; accumulate standard charge sets for a rate
54 ; check the billing rate is correct and return all relevant info
55 ; Output: ARR(event type) = event type name
56 ; ARR(event type, X) = CS name ^ CS IFN ^ default rev code ^ rev code to store ^ description of charge
57 N IBX,IBCS,IBLN,IBERROR S (IBERROR,IBX)=""
58 S IBCS=$O(^IBE(363.1,"B",IBCSN,0)) I +IBCS D
59 . S IBLN=$G(^IBE(363.1,IBCS,0)) Q:IBLN=""
60 . I $P(IBLN,U,2)'=+IBRATE S IBERROR="*** Error: Charge Set "_IBCSN_" is not a "_$P(IBRATE,U,2)_" rate." Q
61 . S IBX=IBCS,ARR(TYPE,ITEM)=IBCSN_U_IBCS_U_$S($G(RVCD):RVCD,1:$P(IBLN,U,5))_U_$G(RVCD)_U_$G(DESC)
62 I 'IBX,IBERROR="" S IBERROR="*** Error: The Charge Set "_IBCSN_" was not found."
63 I IBERROR'="" W !!!,IBERROR,!," Can not continue!"
64 Q IBX
65 ;
66SET(IBRATE,ARR) ; add/edit charges: for each type of charge and each item, displays rev code and description
67 ; then askes the user for bedsection and charge
68 ;
69 N IBEFDT,IBTYP,IBBS,IBJ,IBIT,IBLN,IBCS,IBRVCD,IBCHG,IBOCHG,IBCI,IBX,IBDFTY,DIR,DIRUT,DTOUT,DUOUT,X,Y
70 S IBEFDT=+ARR
71 S IBTYP=0 F S IBTYP=$O(ARR(IBTYP)) Q:'IBTYP D Q:IBBS<0
72 . W !!,"--------------------------------------------------------------------------------"
73 . W !,"Enter ",$P(ARR(IBTYP),U,1)," ",$P(IBRATE,U,2)," charges effective ",$$FMTE^XLFDT(IBEFDT),":"
74 . W !,"--------------------------------------------------------------------------------"
75 . S IBDFTY=IBTYP
76 . F IBJ=1:1 W ! S IBBS=$$GETBS(10,$P(ARR(IBTYP),U,2),IBDFTY) Q:IBBS<1 D I IBTYP>1 S IBDFTY=""
77 .. S IBIT=0 F S IBIT=$O(ARR(IBTYP,IBIT)) Q:'IBIT D I $D(DUOUT) Q
78 ... S IBLN=ARR(IBTYP,IBIT),IBCS=$P(IBLN,U,2),IBRVCD=$P(IBLN,U,4),IBOCHG=""
79 ... S IBX=$E($P(IBBS,U,2),1,28)
80 ... S IBX=IBX_$J("",(30-$L(IBX)))_$P(IBLN,U,5)
81 ... S IBX=IBX_$J("",(50-$L(IBX)))_$P($G(^DGCR(399.2,+$P(IBLN,U,3),0)),U,1)_" $ = "
82 ... S IBCI=$$FINDCI^IBCRU4(IBCS,+IBBS,IBEFDT,"",IBRVCD)
83 ... I +IBCI S IBOCHG=$P($G(^IBA(363.2,+IBCI,0)),U,5),DIR("B")=$FN(IBOCHG,"",2)
84 ... S DIR("A")=IBX,DIR(0)="NAO^0:999999:2" D ^DIR K DIR S IBCHG=+Y I IBCHG<1!(IBCHG=IBOCHG) Q
85 ... I 'IBCI S IBCI=$$ADDCI^IBCREF(IBCS,+IBBS,IBEFDT,IBCHG,IBRVCD) I +IBCI W ?74,"added" Q
86 ... I +IBCI D EDITCI^IBCREF(+IBCI,+IBCHG) W ?74,"edited"
87 Q
88 ;
89NPFRC() ; get the default revenue codes for non-professional inpatient services
90 ;
91 N IBX,DIC,X,Y,DTOUT,DUOUT,IBY S IBX=0
92 W !!,"Enter the Revenue Code to use for all non-professional inpatient services:",!
93 S DIC("A")="Room, Board, Nursing Services: ",DIC("B")=101,DIC("S")="I +$P(^(0),U,3)"
94 S DIC="^DGCR(399.2,",DIC(0)="AEQ" D ^DIC I Y<1 G NPFRCQ
95 S IBY=+Y
96 ;
97 S DIC("A")="Ancillary Services: ",DIC("B")=240,DIC("S")="I +$P(^(0),U,3)"
98 S DIC="^DGCR(399.2,",DIC(0)="AEQ" D ^DIC I Y<1 G NPFRCQ
99 S IBX=IBY_U_+Y
100 ;
101NPFRCQ I 'IBX W !!,"Both of these revenue codes are required for the Inpatient Non-Professional",!,"charges to be added to bills. Can Not Continue!",!
102 Q IBX
103 ;
104DISP(IBRATE,ARR) ;
105 N IBTYP,IBI,IBLN
106 W @IOF,!,$P(IBRATE,U,2)," charges effective ",$$FMTE^XLFDT(ARR)," will be added as follows:"
107 W !,"Charge Type",?30,"Charge Set",?55,"Rev Code",!,"--------------------------------------------------------------------------------",!
108 S IBTYP=0 F S IBTYP=$O(ARR(IBTYP)) Q:'IBTYP D
109 . W $P(ARR(IBTYP),U,1)
110 . S IBI=0 F S IBI=$O(ARR(IBTYP,IBI)) Q:'IBI D
111 .. S IBLN=ARR(IBTYP,IBI)
112 .. W ?30,$P(IBLN,U,1),?55,$P($G(^DGCR(399.2,+$P(IBLN,U,3),0)),U,1),?65,$P(IBLN,U,5),!
113 W !,"If any of the revenue codes are incorrect then change the Default Revenue for",!,"the Charge set." W:+IBRATE=1 " (except the non-prof inpt rev codes entered above)"
114 W !!,"If any of the Charge Sets are incorrect DO NOT USE this option."
115 W !,"This option may NOT be used to delete rates or add zero charges."
116 W !!,"The charges will be asked in sections based on the Charge Types listed above."
117 W !,"The first section is INPATIENT, enter all Inpatient Bedsections and their"
118 W !,"charges, then press return at the Select Bedsection prompt to move to the"
119 W !,"OUTPATIENT VISIT section and enter the Outpatient Visit Bedsection and charge..."
120 W ! S DIR(0)="E" D ^DIR K DIR
121 Q
122 ;
123GETBS(COL,PROMPT,TYPE) ; ask and return billable bedsection (399.1): (-1 if ^, 0 if none) IFN^.01
124 ; if type is inpatient then not PRESCRIPTION or OUTPATIENT bedsections can be selected
125 ; if type is not inpatient then default bedsections are provided
126 N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
127 S DIC("S")="I +$P(^(0),U,5)=1"
128 I $G(TYPE)=1 S DIC("S")=DIC("S")_",$P(^(0),U,1)'[""OUTPATIENT"",$P(^(0),U,1)'[""PRESCRIPTION"""
129 I +$G(TYPE)>1 S DIC("B")=$S(TYPE=3:"PRESCRIPTION",TYPE=4:"OUTPATIENT DENTAL",1:"OUTPATIENT VISIT")
130 S DIC("A")=$J("",$G(COL))_"Select "_$G(PROMPT)_" BEDSECTION: "
131 S DIC="^DGCR(399.1,",DIC(0)="AENQ" D ^DIC K DIC
132 I $D(DTOUT)!($D(DUOUT)) S IBX=-1
133 I +Y>0 S IBX=Y
134 Q IBX
135 ;
136MT() ; do the new mt rate format (misc type) eff 12/6/01 ib*2*167
137 N IBCS,IBTYPE,IBITEM,IBCI,IBX,IBOCHG,DIR,X,Y,IBCHG,IBERROR
138 S IBCS=$$CSN^IBCRU3("TL-MT OPT COPAY"),(IBOCHG,IBERROR)=""
139 I 'IBCS W !,"*** Error: Charge set TL-MT OPT COPAY not found" Q 1
140 W !!,"--------------------------------------------------------------------------------"
141 W !,"Enter MT OUTPATIENT COPAYMENT charges effective ",$$FMTE^XLFDT(IBEFDT),":"
142 W !,"--------------------------------------------------------------------------------"
143 F IBTYPE="BASIC CARE","SPECIALTY CARE" D Q:$L(IBERROR)
144 . S IBITEM=+$$ADDBI^IBCREF("MISCELLANEOUS",IBTYPE)
145 . I 'IBITEM S IBERROR="*** Error: Billable Item "_IBTYPE_" not found" Q
146 . S IBX=IBTYPE_$J("",(50-$L(IBTYPE)))_"$ ="
147 . S IBCI=$$FINDCI^IBCRU4(IBCS,+IBITEM,IBEFDT)
148 . I +IBCI S IBOCHG=$P($G(^IBA(363.2,+IBCI,0)),U,5),DIR("B")=$FN(IBOCHG,"",2)
149 . S DIR("A")=IBX,DIR(0)="NAO^0:999999:2" D ^DIR K DIR S IBCHG=+Y I IBCHG<1!(IBCHG=IBOCHG) Q
150 . I 'IBCI S IBCI=$$ADDCI^IBCREF(IBCS,+IBITEM,IBEFDT,IBCHG) I +IBCI W ?74,"added" Q
151 . I +IBCI D EDITCI^IBCREF(+IBCI,+IBCHG) W ?74,"edited"
152 W !,IBERROR
153 Q $L(IBERROR)
Note: See TracBrowser for help on using the repository browser.