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

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

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1IBCF31 ;ALB/BGA -UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
2 ;;2.0;INTEGRATED BILLING;**17,52,80,51**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ;This routine requires prior execution of ibcf3.
6 ; OUTPUT FORMATTER DOES NOT USE THIS ROUTINE - MAY BE OBSOLETE
7 ;Field locators 22-62 are addressed here.
8 ;
9 S IBMAIL1=$G(^DGCR(399,IBIFN,"M1"))
10 ;
1122 ;patient status
12 S IBFL(22)="" I +IBINPAT,$P(IBSTATE,U,12) S IBX=$P(IBSTATE,U,12),IBFL(22)=$P($G(^DGCR(399.1,+IBX,0)),U,2)
1323 ;medical/health record number ssn
14 S IBFL(23)=$P(VADM(2),U,2)
15 ;
1624 ;condition codes 24-30
17 S (IBI,IBJ)=0 F S IBJ=$O(^DGCR(399,+IBIFN,"CC",IBJ)) Q:'IBJ S IBX=+$G(^(IBJ,0)),IBI=IBI+1,IBFL(24,IBI)=$P($G(^DGCR(399.1,+IBX,0)),U,2)
18 S IBFL(24)=IBI_U_0
19 ;
20 S IBX=$P(IBCUF3,U,3) D SPLIT^IBCF3(31,2,6,IBX) ; set IBFL(31)
2132 ;occurrence codes/span and dates 32-35 ,36
22 ;S (IBI,IBJ,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"OC",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBC=$G(^DGCR(399.1,+IBY,0)) I IBC'="" D
23 ;. I +$P(IBC,U,10) S IBJ=IBJ+1,IBFL(36,IBJ)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))_U_$$DATE^IBCF3($P(IBY,U,4)) Q
24 ;. S IBI=IBI+1,IBFL(32,IBI)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))
25 ;S IBFL(32)=IBI_U_0
26 ;S IBFL(36)=IBJ_U_0
27 D 32^IBCF32
28 ;
29 F IBI=1:1:3 S IBFL(37,IBI)=$P(IBCUF3,U,(IBI+3))
30 ;
3138 ;responsible party with name and address
32 S IBFL(38,1)="" I $P(IBPMAILN,U,4)'="" S IBJ=0 D
33 . F IBI=4,5,6 I $P(IBPMAILN,U,IBI)'="" S IBJ=IBJ+1,IBFL(38,IBJ)=$P(IBPMAILN,U,IBI)
34 . S IBX=$P(IBMAIL1,U,1) I IBX'="" S IBJ=IBJ+1,IBFL(38,IBJ)=IBX
35 . K Y S Y=$P(IBPMAILN,U,9) D ZIPOUT^VAFADDR
36 . S IBJ=IBJ+1,IBFL(38,IBJ)=$P(IBPMAILN,U,7)_", "_$$STATE(+$P(IBPMAILN,U,8))_" "_Y K Y
37 ;
38 ;
3939 ;value codes, 39-41
40 S (IBI,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"CV",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBJ=$G(^DGCR(399.1,+IBY,0)) I IBJ'="" D
41 . S IBI=IBI+1,IBFL(39,IBI)=$P(IBJ,U,2)_U_$P(IBY,U,2)_U_$P(IBJ,U,12)
42 S IBFL(39)=IBI_U_0
43 ;
44 S IBFL(57)=$P(IBCUF31,U,1)
45 S IBX=$P(IBCUF3,U,7) D SPLIT^IBCF3(56,5,14,IBX) ; set IBFL(56)
46 I IBX="" F IBI=2,3,4 S IBX=+$P(IBMAIL1,U,(IBI+3)) I +IBX S IBFL(56,IBI)=$$BN1^PRCAFN(IBX) ; use prior bills
47 ;
4850 F IBI=1:1:3 F IBJ=50:1:54,58:1:66 S IBFL(IBJ,IBI)=""
49 I '$D(^DGCR(399,IBIFN,"AIC")) D G 80
50 . S IBFL(52,1)=$S(+$P(IBSTATE,U,5):"R",1:"Y") ; roi
51 . S IBFL(53,1)=$S("Nn0"[$P(IBSTATE,U,6)&($P(IBSTATE,U,6)'=""):"N",1:"Y") ; assign of benifits
52 . S IBFL(63,1)=$P(IBSTATE,U,13) ; tx auth cd
53 . I $P($G(^DGCR(399.3,+$P(IBCBILL,U,7),0)),U,1)["MEDICARE ESRD" D
54 .. S IBFL(50,1)="MEDICARE ESRD",IBFL(51,1)=$P(IBSIGN,U,21),IBFL(58,1)=VADM(1),IBFL(59,1)="01",IBFL(60,1)=$P(VADM(2),U,2)
55 ;
56INS ;list the primary, secondary .. insurance companies
57 F IBI=1:1:3 S IBJ="I"_IBI S IBX=$G(^DGCR(399,IBIFN,IBJ)) I IBX'="" D
58 . S IBY=$G(^DIC(36,+IBX,0)) Q:IBY=""
59 . S IBFL(50,IBI)=$P(IBY,U,1) ; payer
60 . S IBFL(51,IBI)=$P(IBMAIL1,U,(IBI+1)) ; provider #
61 . S IBFL(52,IBI)=$S(+$P(IBSTATE,U,5):"R",1:"Y") ; roi
62 . S IBFL(53,IBI)=$S("Nn0"[$P(IBSTATE,U,6)&($P(IBSTATE,U,6)'=""):"N",1:"Y") ;assign of benifits
63 . S IBFL(54,IBI)=$P(IBCU2,U,3+IBI) ;prior payment
64 . S IBFL(58,IBI)=$P(IBX,U,17) ; insureds name
65 . S IBFL(59,IBI)=$P(IBX,U,16) ; pt. rel to insured
66 . S IBFL(60,IBI)=$P(IBX,U,2) ; insurance number
67 . S IBFL(61,IBI)=$P(IBX,U,15) ; insurance group name
68 . S IBFL(62,IBI)=$P(IBX,U,3) ; insurance group number
69 . S IBFL(63,IBI)="" I IBI=1 S IBFL(63,IBI)=$P(IBSTATE,U,13) ; tx auth cd
70 . I $P(IBX,U,6)="v" D
71 .. D OPD^VADPT S IBFL(64,IBI)=$P(VAPD(7),U,1) K VAPD I ",3,9,"[+IBFL(64,IBI) Q
72 .. S VAOA("A")=5 D OAD^VADPT S IBFL(65,IBI)=VAOA(9),IBFL(66,IBI)=VAOA(4)_$S(VAOA(4)'="":", ",1:"")_$P(VAOA(5),U,2) K VAOA
73 . I $P(IBX,U,6)="s" D
74 .. S IBFL(64,IBI)=$P($G(^DPT(DFN,.25)),U,15) I ",3,9,"[+IBFL(64,IBI) Q
75 .. S VAOA("A")=6 D OAD^VADPT S IBFL(65,IBI)=VAOA(9),IBFL(66,IBI)=VAOA(4)_$S(VAOA(4)'="":", ",1:"")_$P(VAOA(5),U,2)
76 . I 'IBFL(64,IBI) S IBFL(64,IBI)=9
77 ;
7880 ;procedure field locator 80
79 K IBPROC
80 D PROC^IBCVA1 S IBFL(80)=IBPROC_U_0_U_1,IBFL(80,1)=""
81 I +IBPROC S (IBI,IBX)=0 F S IBX=$O(IBPROC(IBX)) Q:'IBX D
82 . S IBY=$P($$PRCD^IBCEF1($P(IBPROC(IBX),U)),U)
83 . S IBI=IBI+1,IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($P(IBPROC(IBX),U,2))
84 . I $P(IBPROC(IBX),U,15)'="" S IBM=$P(IBPROC(IBX),U,15) D
85 .. F I=1:1:$L(IBM,",") I $P(IBM,",",I)'="" S IBY=$P($$MOD^ICPTMOD($P(IBM,",",I),"I"),U,4) I IBY'="" S IBI=IBI+1,IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($P(IBPROC(IBX),U,2))
86 K IBPROC,I,J
87 ;
88 Q
89 ;
90STATE(X) ;returns 2 letter abbreviation for state pointer
91 Q $P($G(^DIC(5,+$G(X),0)),U,2)
Note: See TracBrowser for help on using the repository browser.