source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF23.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: 7.3 KB
Line 
1IBCF23 ;ALB/ARH - HCFA 1500 19-90 DATA (block 24, procs and charges) ;12-JUN-93
2 ;;2.0;INTEGRATED BILLING;**52,80,106,122,51,152,137**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;requires IBIFN,IB(0),IB("U"),IB("U1"), returns # of line items in IBFLD(24)
6 ;rev code array: IBRC("proc^division^basc flag^bedsection^rev code^unit chrg^Rx seq #")=units
7 ;proc array: IBCP(initial print ord)=proc date^proc^division^basc flag^dx^pos^tos^modifier^unit chrg^purch chrg amt^anesthesia mins^emerg indicator
8 ; IBCP(initial print order,seq #)=auxillary data
9 ;proc array: IBSS("proc^division^basc flag^dx^pos^tos^modifier^unit chrg^Rx seq #")=lowest inital print order
10 ;print order array: IBPO(final print ord,emerg indicator,initial print order)=""
11 ;print array: IBFLD(24,I)=begin dt^end dt^pos^tos^proc^dx^unit chrg^units^modifier pointer ien(s) separated by commas^purch chrg amt^anesthesia mins^emerg indicator
12 ; IBFLD(24,I,"AUX")=[auxillary data]
13 ; = "AUX" node of proc entry
14 ; IBFLD(24,I,"RX")= soft link to file 362.4 or null
15 ; if service is Rx, but no soft link
16 ;
17 ;charge item link: IBLINK(CPT IFN in multiple,RCIFN) = proc^division^basc flag^bedsection^rev code^unit chrg^rx seq #
18 ;
19 ; dx's used in arrays are ref #s
20 ;
21RVC ; charges array
22 D RVCE(,IBIFN)
23 Q
24 ;
25RVCE(IBXIEN,IBIFN) ;Entry for EDI formatter call (IBXIEN will be defined)
26 ; IBIFN required
27 N IBRC,IBCP,IBSS,IBSSO,IBSS1,IBPO,IBLINK,IBLINK1,IBLINKRX,IBK,IBAUXLN
28 N IBI,IBJ,IB11,IBLN,IBPDT,IBCHARG,IBMOD,IBPC,IBRX,IBRXF,IBPO2A,IBAUX
29 ;
30 S IBRX=0
31 S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"RC",IBI)) Q:'IBI S IBLN=^(IBI,0) D
32 . S IBSS="",IBPC=0 F IBJ=6,7,0,5,1,2,14 S IBPC=IBPC+1 S:IBJ $P(IBSS,U,IBPC,IBPC+1)=($P(IBLN,U,IBJ)_U)
33 . I $P(IBSS,U,2)="" S $P(IBSS,U,2)=$P(^DGCR(399,IBIFN,0),U,22)
34 . I +IBSS S $P(IBSS,U)=$P(IBSS,U)_";ICPT("
35 . S $P(IBSS,U,3)=$S($D(^DGCR(399,"ASC1",+$P(IBLN,U,6),IBIFN,IBI)):1,1:"")
36 . I +$P(IBLN,U,10)=3 D Q ; Rx
37 .. I '$P(IBLN,U,15) S IBRX=IBRX+1,$P(IBSS,U,8)=(100+IBRX)
38 .. I $P(IBLN,U,15) S $P(IBSS,U,8)=$P(IBLN,U,15)
39 .. S IBRC(IBSS,"RX")=$P(IBLN,U,11)_U_IBI_U_$P(IBLN,U,15)
40 .. S IBRC(IBSS)=$G(IBRC(IBSS))+1
41 . ;
42 . S IBRC(IBSS)=$G(IBRC(IBSS))+$P(IBLN,U,3) ; total units for similar RC
43 . I "4"[+$P(IBLN,U,10),$P(IBLN,U,11) D ; Soft-link proc with the rev cd
44 .. S IBLINK(+$P(IBLN,U,11),IBI)=IBSS
45 .. S $P(IBLINK(+$P(IBLN,U,11),IBI),U,7)=$P(IBLN,U,14)
46 . I $P(IBLN,U,10) D
47 .. S IBLINK1(IBSS,IBI)=$P(IBLN,U,10)_U_+$P(IBLN,U,11)
48 ;
49 S IBSSO="" F S IBSSO=$O(IBRC(IBSSO)) Q:IBSSO="" I $D(IBRC(IBSSO,"RX")) D
50 . S IBSS=IBSSO,IBI=$P(IBRC(IBSSO,"RX"),U,2),IB11=$P(IBRC(IBSSO,"RX"),U,3)
51 . S IBRC(IBSSO)=1,IBLINKRX($S($P(IBSSO,U)>0:$P(IBSSO,U),$P($G(^DGCR(399,IBIFN,"CP",+IB11,0)),U)'="":$P(^(0),U),1:0),+IB11,+IBRC(IBSSO,"RX"))=IBSSO K IBRC(IBSSO,"RX")
52 ;
53 D PRC^IBCF23A ; Extract procedures
54PO ; print order array w/chrgs
55 ; combine multiple entries of same proc onto one line item via print order
56 ;if both have print orders defined then they should not be combined onto one line item
57 ;"proc^division^basc^dx^pos^tos^modifier(s)^unit chrg^purchased chg" must all be the same as well as the emergency indicator and all 'aux flds'
58 N IBP,Z
59 S IBPO="" F S IBPO=$O(IBCP(IBPO)) Q:'IBPO S IBCP=IBCP(IBPO),IBSS=$P(IBCP,U,2,9),IBSS1="*"_$G(IBCP(IBPO,"AUX")),IBAUX=0 D
60 . I $D(IBSS(IBSS)),'$D(IBCP(IBPO,"RX")),IBPO>1000 D Q ; combine lines
61 .. I 'IBAUX S IBAUX=$$AUXOK^IBCF23A(.IBSS,IBSS1)
62 .. S IBPO1=$S(IBAUX:IBSS(IBSS,IBAUX),1:IBPO)
63 .. I 'IBAUX S Z=+$O(IBSS(IBSS,"A"),-1)+1,IBSS(IBSS,Z)=IBPO
64 .. I IBPO>1000!(IBPO1>1000) S IBPO(IBPO1,+$P(IBCP,U,12),IBPO)="" D
65 ... I $O(IBCP(IBPO,"L",0)) S Z=$O(IBCP(IBPO,"L",0)),IBPO(IBPO1,+$P(IBCP,U,12),IBPO,"L",Z)=IBCP(IBPO,"L",Z) K IBCP(IBPO,"L",Z)
66 . S IBAUX=+$O(IBSS(IBSS,"A"),-1)+1,IBSS(IBSS,"AUX-X",IBAUX)=IBSS1
67 . S IBSS(IBSS,IBAUX)=+IBPO,IBPO(+IBPO,+$P(IBCP,U,12),IBPO)=""
68 . S Z=0 F S Z=$O(IBCP(IBPO,Z)) Q:'Z S IBPO(+IBPO,+$P(IBCP,U,12),IBPO,Z)=""
69 . I $O(IBCP(IBPO,"L",0)) S Z=$O(IBCP(IBPO,"L",0)),IBPO(+IBPO,+$P(IBCP,U,12),IBPO,"L",Z)=IBCP(IBPO,"L",Z) K IBCP(IBPO,"L",Z)
70 . S IBSS(IBSS,IBAUX,"AUX")=IBSS1,IBPO(+IBPO,+$P(IBCP,U,12),IBPO,"AUX")=$E(IBSS1,2,$L(IBSS1))
71 . I $D(IBCP(IBPO,"RX")) S IBPO(+IBPO,+$P(IBCP,U,12),IBPO,"RX")=IBCP(IBPO,"RX"),IBSS(IBSS,IBAUX,"RX")=IBCP(IBPO)
72 ;
73 ; Find any remaining rev codes w/units that ref existing procedures
74 S IBP(0)=0
75 F IBP=3,2 Q:$G(IBP(0)) S IBRV="" F S IBRV=$O(IBRC(IBRV)) Q:IBRV="" I IBRV,IBRC(IBRV) D
76 . S IBSS1=$O(IBSS($P(IBRV,U,1,IBP))) Q:$P(IBRV,U,1,IBP)'=$P(IBSS1,U,1,IBP)
77 . S IBP(0)=1,Z=0
78 . F S Z=$O(IBSS(IBSS1,Z)) Q:'Z I $G(IBSS(IBSS1,Z)) D Q
79 .. I $D(IBCP(IBSS(IBSS1,Z))),$P(IBCP(IBSS(IBSS1,Z)),U,9)=$P(IBSS1,U,8) D
80 ... N Q,Q0
81 ... S Q=$O(IBCP(""),-1)+1,Q0=$P(IBCP(IBSS(IBSS1,Z)),U,12)
82 ... M IBPO(Q,$P(IBCP(IBSS(IBSS1,Z)),U,12),Q)=IBPO(IBSS(IBSS1,Z),$P(IBCP(IBSS(IBSS1,Z)),U,12),IBSS(IBSS1,Z)),IBCP(Q)=IBCP(IBSS(IBSS1,Z))
83 ... S $P(IBCP(Q),U,9)=$P(IBRV,U,6)
84 ... F Z0=1:1:(IBRC(IBRV)-1) S IBPO(Q,Q0,Q+(Z0*.01))=IBPO(Q,Q0,Q) I Z0=99,(IBRC(IBRV)'=100) S IBPO(Q,Q0,Q_".991")=(IBRC(IBRV)-1)_"^99" Q ; Only put first 99 in array
85 ... S IBRC(IBRV)=0
86 ;
87PRTARR ;print proc array
88 S IBREV="",IBPO1="",IBI=0 F S IBPO1=$O(IBPO(IBPO1)) Q:IBPO1="" D
89 . K IBRXF
90 . S IBEMG="" F S IBEMG=$O(IBPO(IBPO1,IBEMG)) Q:IBEMG=""!("01"'[IBEMG) S IBPO2="" D
91 .. S IBDT1=99999999,IBDT2="",(IBMIN,IBUNIT)=0,(IBCHARG,IBAUX)=""
92 .. F S IBPO2=$O(IBPO(IBPO1,IBEMG,IBPO2)) Q:IBPO2="" D
93 ... I IBPO2#1=.991 D Q:IBPO2#1=.991
94 .... N Z
95 .... S Z=$G(IBPO(IBPO1,IBEMG,IBPO2)) Q:'Z
96 .... I ($P(Z,U,2)+1)>Z Q
97 .... S $P(IBPO(IBPO1,IBEMG,IBPO2),U,2)=($P(Z,U,2)+1),IBPO2=(IBPO2\1)_".99"
98 ... S Z=0 F S Z=$O(IBPO(IBPO1,IBEMG,IBPO2,Z)) Q:'Z S IBUNIT=IBUNIT+1
99 ... S IBPO2A=$S('$D(IBCP(IBPO2)):IBPO2\1,1:IBPO2)
100 ... S IBCHARG=$P(IBCP(IBPO2A),U,9),IBPCHG=$P(IBCP(IBPO2A),U,10)
101 ... I IBCHARG<10000,IBCHARG*(IBUNIT+1)'<10000 D Q ;$9,999 limit per line
102 .... N Z S Z=$O(IBPO(IBPO1\1+1),-1),Z=Z+$S(IBPO1+.001'=Z:.001,1:0) M IBPO(Z,IBEMG,IBPO2)=IBPO(IBPO1,IBEMG,IBPO2) K IBPO(IBPO1,IBEMG,IBPO2)
103 ... S IBUNIT=IBUNIT+1,IBSS=IBCP(IBPO2A),IBMIN=IBMIN+$P(IBSS,U,11)
104 ... S Z=$O(IBPO(IBPO1,IBEMG,IBPO2,"L",0)) I Z D
105 .... S Z0=0
106 .... F Z=Z:1 Q:'$O(IBPO(IBPO1,IBEMG,IBPO2,"L",0))!(Z0=IBUNIT) I $D(IBPO(IBPO1,IBEMG,IBPO2,"L",Z)) S IBSS("L",Z)=IBPO(IBPO1,IBEMG,IBPO2,"L",Z),Z0=Z0+1 K IBPO(IBPO1,IBEMG,IBPO2,"L",Z)
107 ... S:IBDT1>+IBSS IBDT1=+IBSS S:IBDT2<+IBSS IBDT2=+IBSS
108 .. S IBAUX=$G(IBCP(IBPO1,"AUX")) S:$D(IBCP(IBPO1,"RX")) IBRXF=IBCP(IBPO1,"RX")
109 .. I IBUNIT D B24^IBCF23A
110 .. K IBRXF
111 ;
112 ;print any chrgs not associated with a proc (ie. not enough procs or proc not in "CP" level)
113 S IBRV="" F S IBRV=$O(IBRC(IBRV)) Q:IBRV="" I +IBRC(IBRV) D D B24^IBCF23A K IBRXF
114 . S IBUNIT=+IBRC(IBRV),IBCHARG=$P(IBRV,U,6),IBDT1=+IB("U"),IBDT2=$P(IB("U"),U,2),IBREV=$P(IBRV,U,5),IBEMG=0,IBAUX=""
115 . S IBSS="^"_$S(+IBRV:$P(IBRV,U),1:$P($G(^DGCR(399.1,+$P(IBRV,U,4),0)),U))
116 . S Z=$O(IBLINK1(IBRV,0)) I Z D
117 .. S Z0=0
118 .. F Z=Z:1 Q:'$O(IBLINK1(IBRV,0))!(Z0=IBUNIT) I $D(IBLINK1(IBRV,Z)) S IBSS("L",Z)=IBLINK1(IBRV,Z),Z0=Z0+1 K IBLINK1(IBRV,Z)
119 ;
120OFFSET ;
121 S IBFLD(24)=IBI ;line item count
122 K IBRC,IBCP,IBSS,IBPO,IBPO1,IBPO2,IBLN,IBRV,IBRV1,IBPDT,IBDT1,IBDT2,IBCHARG,IBMIN,IBUNIT,IBREV,IBLINK,IBLINK1,IBEMG,IBPCHG,Z
123 Q
124 ;
125DATE(X) ; Fm dt in X ==> YYYYMMDD
126 Q $$DT^IBCEFG1(X,,"D8")
127 ;
128B24 ; Moved to IBCF23A for space
129 D B24^IBCF23A
130 Q
131 ;
Note: See TracBrowser for help on using the repository browser.