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

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

revised back to 6/30/08 version
File size: 6.6 KB
RevLine 
[623]1IBJTBA ;ALB/ARH - TPI BILL CHARGE INFO SCREEN ;01-MAR-1995
2 ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ; -- main entry point for IBJ TP BILL CHARGES
6 D EN^VALM("IBJT BILL CHARGES")
7 Q
8 ;
9HDR ; -- header code
10 D HDR^IBJTU1(+IBIFN,+DFN,12)
11 Q
12 ;
13INIT ; -- init variables and list array
14 N IBOK,IBEOBDET
15 K ^TMP("IBJTBA",$J) N IBFT
16 I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ
17 S IBFT=+$P($G(^DGCR(399,+IBIFN,0)),U,19),IBOK=1
18 I $D(^IBM(361.1,"B",IBIFN))!$D(^IBM(361.1,"C",IBIFN)) D G:'IBOK INITQ
19 . S DIR("A")="DO YOU WANT ALL EEOB DETAILS?: ",DIR("B")="NO",DIR(0)="YA"
20 . D FULL^VALM1 W ! D ^DIR K DIR
21 . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
22 . S IBEOBDET=+Y
23 D BLD
24INITQ Q
25 ;
26MRA ; -- mra/eob
27 N IBI,Z,IBSTR,IBSHEOB,IBCT
28 S IBCT=0
29 S IBI=0 F S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI S Z=+$O(^IBM(361.1,IBI,8,0)) I '$O(^(Z)) S IBCT=IBCT+1,IBSHEOB(IBI)=0 ; Entire EOB belongs to the bill
30 S IBI=0 F S IBI=$O(^IBM(361.1,"C",IBIFN,IBI)) Q:'IBI S IBCT=IBCT+1,IBSHEOB(IBI)=1 ; EOB has been reapportioned at the site
31 I 'IBCT D
32 . S IBSTR=$$SETLN("No EEOB/MRA Information","",1,79)
33 . S IBLN=$$SET(IBSTR,IBLN)
34 I IBCT D
35 . S Z=0
36 . S IBI=0 F S IBI=$O(IBSHEOB(IBI)) Q:'IBI S Z=Z+1 D SHEOB^IBJTBA1(IBI,+IBSHEOB(IBI),Z,IBCT)
37 ;
38 Q
39 ;
40HELP ; -- help code
41 S X="?" D DISP^XQORM1 W !!
42 Q
43 ;
44EXIT ; -- exit code
45 K ^TMP("IBJTBA",$J)
46 D CLEAR^VALM1
47 Q
48 ;
49BLD ; charges, as they would display on the bill
50 N IBXDATA,IBXSAVE
51 I $P($G(^DGCR(399,+IBIFN,0)),U,19)=2 D H1500 Q
52 D UB04
53 K ^TMP("IBXSAVE",$J)
54 Q
55 ;
56H1500 ; block 24
57 N X,IBI,IBJ,IBLN,IBX,IBSTR,IBLKLN,IBPFORM,IBLIN
58 K ^TMP("IBXSAVE",$J)
59 S IBLIN=$$BOX24D^IBCEF11("",1),IBLKLN=0,IBLN=1
60 Q:'$G(IBIFN) K ^TMP("IBXDISP",$J)
61 S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2),IBLN=1
62 S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
63 S IBI=$O(^TMP("IBXDISP",$J,""),-1)
64 S IBJ="" F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ),-1) Q:$S('IBJ:1,1:$TR($G(^(IBJ))," ")'="") K ^TMP("IBXDISP",$J,IBI,IBJ)
65 I '$O(^TMP("IBXDISP",$J,IBI,0)) S VALMSG="No charges or procedures defined.",VALMQUIT="" G H1500Q
66 S IBI="" F S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ D
67 . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN)
68 K ^TMP("IBXDISP",$J)
69 D COB,MRA
70 I $$ISRX^IBCEF1(IBIFN) D RX
71 I $$ISPROS^IBCEF1(IBIFN) D PROS
72 S VALMCNT=IBLN-1
73H1500Q Q
74 ;
75UB04 ;form locator 42-49, IBIFN required
76 N X,Y,DIR,IBI,IBJ,IBX,IBLN,IBLC,IBLIN,IBPFORM,IBSTATE,IBCBILL,IBINPAT,IBQ,Z,Z0
77 K ^TMP("IBXSAVE",$J)
78 S IBLIN=$$RCBOX^IBCEF11()
79 S IBQ=0,IBLC=9 Q:'$G(IBIFN) K ^TMP("IBXDISP",$J)
80 S IBPFORM=$S($P($G(^IBE(353,3,2)),U,8):$P(^(2),U,8),1:3)
81 S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
82 I '$O(^TMP("IBXDISP",$J,0)) S VALMSG="No charges defined.",VALMQUIT="" G UB04Q
83 S Z="" F S Z=$O(^TMP("IBXDISP",$J,1,Z),-1) Q:Z="" S Z0=$G(^(Z)) Q:$TR(Z0," ")'="" K ^(Z)
84 S:Z ^TMP("IBXDISP",$J,1,Z+1)=" "
85 S IBINPAT=$$INPAT^IBCEF(IBIFN,1)
86 S IBSTATE=$G(^DGCR(399,IBIFN,"U")),IBCBILL=$G(^DGCR(399,IBIFN,0))
87 ;
88 S (VALMCNT,IBLN)=1,IBLKLN=0
89 I +IBINPAT D S IBLN=$$SET(IBSTR,IBLN)
90 . S IBX=$P(IBSTATE,U,15),IBSTR=+IBX_" DAY"_$S(IBX'=1:"S",1:"")_" INPATIENT CARE"
91 . S IBX=$$LOS^IBCU64(+IBSTATE,+$P(IBSTATE,U,2),+$P(IBCBILL,U,6)),IBX=IBX-$$LOS1^IBCU64(IBIFN) I IBX>0 S IBSTR=IBSTR_$J("Pass Days: "_IBX,55)
92 ;
93 S IBI="" F S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ D
94 . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN)
95 . I $E(IBX,1,3)="001" D COB
96 ;
97 K ^TMP("IBXDISP",$J)
98 ;
99 D MRA
100 S VALMCNT=IBLN-1
101UB04Q Q
102 ;
103SETLN(STR,IBX,COL,WD) ;
104 S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
105 Q IBX
106 ;
107SET(STR,LN) ; set up TMP array with screen data (allows 2 blank lines, if not at end of array)
108 N IBX,IBI I STR?80" " S IBLKLN=IBLKLN+1 G SETQ
109 F IBI=1:1:IBLKLN D SET^VALM10(LN," ") S LN=LN+1 Q:IBI>1
110 D SET^VALM10(LN,STR)
111 S LN=LN+1,IBLKLN=0
112SETQ Q LN
113 ;
114COB ; if there is an offset or a secondary/tertiary payer add it to the display, with ins co, and prior bill #
115 ; IBIFN and IBLN must exist upon entry, IBLN is updated with new line count
116 N IBM,IBM1,IBI,IBJ,IBD,IBSTR,IBCU2,IBCU1 Q:'$G(IBIFN)
117 S IBM=$G(^DGCR(399,IBIFN,"M")),IBM1=$G(^DGCR(399,IBIFN,"M1"))
118 S IBCU2=$G(^DGCR(399,IBIFN,"U2")),IBCU1=$G(^DGCR(399,IBIFN,"U1"))
119 S IBJ=$P($G(^DGCR(399,IBIFN,0)),U,21),IBJ=$S(IBJ="P":3,IBJ="S":3,IBJ="T":3,1:0),IBSTR=""
120 I +$P(IBM,U,2)!(+$P(IBM,U,3)) F IBI=1:1:IBJ I +$P(IBM,U,IBI) D S IBLN=$$SET(IBSTR,IBLN)
121 . I IBSTR="" S IBLN=$$SET("",IBLN)
122 . S IBD=$S(IBI=1:"Primary",IBI=2:"Secondary",1:"Tertiary")_": " S IBSTR=$$SETLN(IBD,"",5,11)
123 . S IBD=$P($G(^DIC(36,+$P(IBM,U,IBI),0)),U,1) S IBSTR=$$SETLN(IBD,IBSTR,17,25)
124 . I $P(IBCU2,U,(IBI+3))'="" S IBD=$J(+$P(IBCU2,U,(IBI+3)),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11)
125 . I $P(IBM1,U,(IBI+4))'="" S IBD=$$BN1^PRCAFN(+$P(IBM1,U,(IBI+4))) S IBSTR=$$SETLN(IBD,IBSTR,60,11)
126 I +$P(IBCU1,U,2) D S IBLN=$$SET(IBSTR,IBLN)
127 . I IBSTR="" S IBLN=$$SET("",IBLN)
128 . S IBD="Offset: " S IBSTR=$$SETLN(IBD,"",5,11)
129 . S IBD=$P(IBCU1,U,3) S IBSTR=$$SETLN(IBD,IBSTR,17,25)
130 . S IBD=$J($P(IBCU1,U,2),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11)
131 . S IBD=$P(IBCU1,U,1)-$P(IBCU1,U,2),IBD="Billed: "_$J(IBD,0,2) S IBSTR=$$SETLN(IBD,IBSTR,60,17)
132 Q
133 ;
134RX ;RX refill info for CMS-1500 TPJI display
135 N Z,Z0,Z1,IBSPC,IBD,IBI,IBSTR,IBARRAY,IBRXX
136 S IBLN=IBLN+1
137 S IBSPC=$J("",5)
138 D SET^IBCSC5A(IBIFN,.IBARRAY)
139 I $D(IBARRAY) D
140 . S (Z,Z0)=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1 S IBXDATA(Z)=$$DAT1^IBOUTL(Z1)_U_$G(IBARRAY(Z0,Z1))
141 S IBD=$$SET("",IBLN)
142 S IBD="PRESCRIPTION REFILLS: (For TPJI display only)"
143 S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
144 S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:IBI="" D
145 . S IBRXX=$G(IBXDATA(IBI))
146 . D ZERO^IBRXUTL($P(IBRXX,U,3))
147 . S IBD=$J($P(IBRXX,U,7),9,2)_IBSPC_$P(IBRXX,U)_IBSPC_$G(^TMP($J,"IBDRUG",+$P(IBRXX,U,3),.01))
148 . K ^TMP($J,"IBDRUG")
149 . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
150 . S IBD="QTY: "_$P(IBRXX,U,5)_" for "_$P(IBRXX,U,4)_" days supply "_"NDC# "_$P(IBRXX,U,6)
151 . S IBSTR=$$SETLN(IBD,"",23,79),IBLN=$$SET(IBSTR,IBLN)
152 Q
153 ;
154PROS ;prosthetic info for CMS-1500 TPJI display
155 N Z,Z0,Z1,IBARRAY,IBSPC,IBD,IBI,IBSTR
156 S IBSPC=$J("",10),IBLN=IBLN+1
157 D SET^IBCSC5B(IBIFN,.IBARRAY)
158 I $D(IBARRAY) D
159 . S (Z,Z0)=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($P($$PIN^IBCSC5B(Z1),U,2),1,39)
160 S IBD=$$SET("",IBLN)
161 S IBD="PROSTHETIC REFILLS: (For TPJI display only)"
162 S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
163 S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:IBI="" D
164 . S IBD=$P(IBXDATA(IBI),U)_IBSPC_$P(IBXDATA(IBI),U,2)
165 . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
166 Q
167 ;
Note: See TracBrowser for help on using the repository browser.