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

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

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1IBCRU1 ;ALB/ARH - RATES: UTILITIES ; 22-MAY-1996
2 ;;2.0;INTEGRATED BILLING;**52,106,210**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6EMUTL(X,LNG) ; returns external form of an MCCR Utility entry (399.1), full or abbrev.
7 S X=$G(^DGCR(399.1,+$G(X),0)),LNG=$S(+$G(LNG)=2:3,1:1)
8 S X=$P(X,U,LNG)
9 Q X
10 ;
11MCCRUTL(N,P) ; returns IFN of MCCR Utility entry (399.1) if Name N is found and piece P is true
12 N X,I,Y S X=0
13 I +$G(P),$G(N)'="" S I=0 F S I=$O(^DGCR(399.1,"B",$E(N,1,30),I)) Q:'I S Y=$G(^DGCR(399.1,I,0)) I +$P(Y,U,P),$P(Y,U,1)=N S X=I Q
14 Q X
15 ;
16EXPAND(FILE,FIELD,VALUE) ; return expanded external form of a data element
17 N Y,C S Y=$G(VALUE)
18 I +$G(FILE),+$G(FIELD),Y'="" S C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ
19 Q Y
20 ;
21DATE(X) ; date in external format
22 N Y S Y="" I $G(X)?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
23 Q Y
24 ;
25GETDT(DEFAULT,PROMPT,MIN,MAX) ; user select effective date (-1 if ^, 0 if none) DT1
26 N IBX,DIR,X,Y,DTOUT,DUOUT,DIRUT S IBX=0 I $G(DEFAULT) S DIR("B")=$$DATE(DEFAULT)
27 S DIR("A")=$S($G(PROMPT)'="":PROMPT,1:"Select EFFECTIVE DATE")
28 S DIR(0)="DO^"_$G(MIN)_":"_$G(MAX)_":EX" D ^DIR K DIR I Y?7N S IBX=+Y
29 I $D(DTOUT)!$D(DUOUT) S IBX=-1
30 Q IBX
31 ;
32GETBR(BI) ; ask and return a billing rate (363.3): (-1 if ^, 0 if none) IFN^.01
33 ; if BI passed in then only allow selection of billing rates with that type of billable item
34 N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
35 I +$G(BI) S DIC("S")="I $P(^(0),U,4)="_BI
36 S DIC="^IBE(363.3,",DIC(0)="AENQ" D ^DIC K DIC
37 I $D(DTOUT)!($D(DUOUT)) S IBX=-1
38 I +Y>0 S IBX=Y
39 Q IBX
40 ;
41GETCS() ; ask and return a charge set (363.2): (-1 if ^, 0 if none) IFN^.01
42 N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
43 S DIC="^IBE(363.1,",DIC(0)="AENQ" D ^DIC K DIC
44 I $D(DTOUT)!($D(DUOUT)) S IBX=-1
45 I +Y>0 S IBX=Y
46 Q IBX
47 ;
48GETSG(TYPE,BR) ; ask and return a special group (363.32): (-1 if ^, 0 if none) IFN^.01
49 ; if TYPE is passed in then only groups of that type may be selected
50 ; if BR is passed in then only groups assigned that billing rate may be selected
51 N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
52 I +$G(TYPE) S DIC("S")="I $P(^(0),U,2)="_TYPE_$S(+$G(BR):" ",1:"")
53 I +$G(BR) S DIC("S")=$G(DIC("S"))_"I $O(^IBE(363.32,Y,11,""B"",+BR,0))"
54 S DIC="^IBE(363.32,",DIC(0)="AENQ" D ^DIC K DIC
55 I $D(DTOUT)!($D(DUOUT)) S IBX=-1
56 I +Y>0 S IBX=Y
57 Q IBX
58 ;
59GETBED(COL) ; ask and return billable bedsection (399.1): (-1 if ^, 0 if none) IFN^.01
60 N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
61 S DIC("A")=$J("",$G(COL))_"Select BEDSECTION: "
62 S DIC="^DGCR(399.1,",DIC(0)="AENQ",DIC("S")="I +$P(^(0),U,5)=1" D ^DIC K DIC
63 I $D(DTOUT)!($D(DUOUT)) S IBX=-1
64 I +Y>0 S IBX=Y
65 Q IBX
66 ;
67GETCPT(COL,ALL) ; ask and return CPT (81): (-1 if ^, 0 if none) IFN^.01
68 N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
69 S DIC("A")=$J("",$G(COL))_"Select CPT: " I '$G(ALL) S DIC("S")="I $$CPTACT^IBACSV(+Y,DT)"
70 S DIC="^ICPT(",DIC(0)="AEMNQ" D ^DIC K DIC
71 I $D(DTOUT)!($D(DUOUT)) S IBX=-1
72 I +Y>0 S IBX=Y
73 Q IBX
74 ;
75GETNDC(COL) ; ask and return NDC #'s (363.21): (-1 if ^, 0 if none) IFN^.01
76 N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
77 S DIC("A")=$J("",$G(COL))_"Select NDC #: "
78 S DIC="^IBA(363.21,",DIC(0)="AENQ",DIC("S")="I +$P(^(0),U,2)=1" D ^DIC K DIC
79 I $D(DTOUT)!($D(DUOUT)) S IBX=-1
80 I +Y>0 S IBX=Y
81 Q IBX
82 ;
83GETDRG(COL,ALL) ; ask and return DRG (80.2): (-1 if ^, 0 if none) IFN^.01
84 ; ALL: Default is 1 (disable screening)
85 N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
86 S DIC("A")=$J("",$G(COL))_"Select DRG: " I '$G(ALL,1) S DIC("S")="I $$DRGACT^IBACSV(+Y,DT)"
87 S DIC="^ICD(",DIC(0)="AEMNQ" D ^DIC K DIC
88 I $D(DTOUT)!($D(DUOUT)) S IBX=-1
89 I +Y>0 S IBX=Y
90 Q IBX
91 ;
92GETMISC(COL,CS) ; ask and return MISCELLANEOUS item (363.21): (-1 if ^, 0 if none) IFN^.01
93 ; if CS is passed in then only billing items with charges in that set are selectable
94 N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
95 S DIC("A")=$J("",$G(COL))_"Select MISCELLANEOUS Item: "
96 S DIC("S")="I +$P(^(0),U,2)=9" I +$G(CS) S DIC("S")=DIC("S")_",$D(^IBA(363.2,""AIVDTS""_+CS,Y))"
97 S DIC="^IBA(363.21,",DIC(0)="AENQ" D ^DIC K DIC
98 I $D(DTOUT)!($D(DUOUT)) S IBX=-1
99 I +Y>0 S IBX=Y
100 Q IBX
101 ;
102GETITEM(IBCSFN,COL,ALL) ; returns user selected item for a specific charge set:
103 ; IFN ^ .01 ^ source file reference ^ source file (-1 if ^, 0 if none)
104 N IBCS0,IBBRFN,IBBR0,IBBRBI,IBITEM S IBITEM=0,COL=$G(COL),ALL=$G(ALL)
105 I '$G(IBCSFN) S IBCSFN=+$$GETCS I IBCSFN'>0 G GIQ
106 ;
107 S IBCS0=$G(^IBE(363.1,+IBCSFN,0)),IBBRFN=$P(IBCS0,U,2)
108 S IBBR0=$G(^IBE(363.3,+IBBRFN,0)),IBBRBI=$P(IBBR0,U,4)
109 ;
110 I IBBRBI=1 S IBITEM=$$GETBED(COL) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
111 I IBBRBI=2 S IBITEM=$$GETCPT(COL,ALL) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
112 I IBBRBI=3 S IBITEM=$$GETNDC(COL) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
113 I IBBRBI=4 S IBITEM=$$GETDRG(COL) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
114 I IBBRBI=9 S IBITEM=$$GETMISC(COL,$S('ALL:+IBCSFN,1:0)) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
115GIQ Q IBITEM
Note: See TracBrowser for help on using the repository browser.