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

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1IBCF32 ;ALB/BGA-UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
2 ;;2.0;INTEGRATED BILLING;**210**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;This routine requires prior execution of ibcf3.
6 ;
7DX ;set diagnosis codes fl 67-71
8 ;S IBX=$G(^DGCR(399,+IBIFN,"C"))
9 ;S IBI=0 F IBJ=14:1:18 S IBFL(67+IBI)=$P($G(^ICD9(+$P(IBX,U,IBJ),0)),U,1),IBI=IBI+1
10 N IBINDXX
11 D SET^IBCSC4D(IBIFN,"",.IBINDXX)
12 S IBX=0 F IBI=1:1:9 S IBX=$O(IBINDXX(IBX)) Q:'IBX D
13 . S IBFL(66+IBI)=$P($$ICD9^IBACSV(+IBINDXX(IBX)),U)
14 ;
1576 ;fl 76 admitting diagnoses (if a ICD dx not entered get old position of dx)
16 S IBCBCOMM=$G(^DGCR(399,+IBIFN,"U1"))
17 S IBX=$P(IBCU2,U) ; Admitting Diagnosis (fld #215) IBCU2=$G(^DGCR(399,+IBIFN,"U2"))
18 I 'IBX S IBFL(76)=$P(IBCBCOMM,U,5) ; Form Locator 9 (Field #205)
19 E S IBFL(76)=$P($$ICD9^IBACSV(+IBX),U)
20 ;
2178 S IBX=$P(IBCUF31,U,2) D SPLIT^IBCF3(78,2,3,IBX) ; set IBFL(78)
22 ;fl 79 procedure coding method used
23 S IBFL(79)=$P(IBCBILL,U,9)
24 ;
2582 ;fl 82 attending physician id
26 S IBFL(82)=$P(IBCBCOMM,U,13) I IBFL(82)="" S IBFL(82)="Dept. Veterans Affairs"
27 ;fl 83 other physician id
28 S IBFL(83)=$P(IBCBCOMM,U,14)
29 ;
3084 ;fl 84 remarks
31 S IBFL(84,1)="Patient ID: "_$P(VADM(2),U,2)
32 S IBX=$P($G(^DGCR(399.3,+$P(IBCBILL,U,7),0)),U,2),IBFL(84,2)="Bill Type: "_$S(IBX'="":IBX,1:"UNSPECIFIED")
33 S IBFL(84,3)=$P(IBSIGN,U,4)
34 S IBFL(84,4)=$P(IBCBCOMM,U,8)
35 ;
3685 ;fl 85 provider representative signature
37 S IBFL(85,1)=$P(IBSIGN,U,1)
38 S IBFL(85,2)=$P(IBSIGN,U,2)
3986 ;date bill submitted
40 S IBX=$P($G(^DGCR(399,+IBIFN,"S")),U,12),IBX=$S(+IBPNT:DT,+IBX:IBX,1:DT),IBFL(86)=$$DATE^IBCF3(IBX)
41 Q
42 ;
43 ;ADD OCCURRENCE CODES AND SPANS TO PRINT ARRAY
4432 ;the following rules apply to printing occurrence codes and spans (see FL 32 in UB-92 manual)
45 ; - fields 32a-36a are used before 32b-36b
46 ; - if all occ code fields are used (32a&b -35a&b) then occ span fields (36a&b) may be used, w/ thru date blank
47 ; - if all occ span fields are used (36a&b) the occ code fields 34&35 may be used, w/ code&from date in 34 and code&thru date in 35
48 ;
49 K IB32,IB36 S IBPG=0 F IBI=32:1:36 K IBFL(IBI) S IBFL(IBI)="0^0"
50 ;occurrence codes/span and dates 32-35 ,36
51 ;load codes and spans into two flat arrays
52 S (IBI,IBJ,IBX)=0
53 F S IBX=$O(^DGCR(399,+IBIFN,"OC",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBZ=$G(^DGCR(399.1,+IBY,0)) I +$P(IBZ,U,4) D
54 . I +$P(IBZ,U,10) S IBJ=IBJ+1,IB36(IBJ)=$P(IBZ,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))_U_$$DATE^IBCF3($P(IBY,U,4)) Q
55 . S IBI=IBI+1,IB32(IBI)=$P(IBZ,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))
56 S IB32=IBI_U_0
57 S IB36=IBJ_U_0
58 ;
59OCC ;
60 S IBPG=IBPG+1
61 S IBI=+$G(IBFL(32))+1
62 I +IB32 F IBI=IBI,IBI+1 S IBX=+$P(IB32,U,2) F IBJ=32,33,34,35 S IBX=$O(IB32(IBX)) Q:'IBX D
63 . S IBFL(IBJ,IBI)=IB32(IBX)
64 . S $P(IBFL(IBJ),U,1)=+IBFL(IBJ)+1
65 . S $P(IB32,U,1)=+IB32-1
66 . S $P(IB32,U,2)=IBX
67 ;
68 S IBX=+$P(IB36,U,2),IBI=+$G(IBFL(36))+1
69 I +IB36 F IBI=IBI,IBI+1 S IBX=$O(IB36(IBX)) Q:'IBX D
70 . S IBFL(36,IBI)=IB36(IBX)
71 . S $P(IBFL(36),U,1)=+IBFL(36)+1
72 . S $P(IB36,U,1)=+IB36-1
73 . S $P(IB36,U,2)=IBX
74 ;
75 I 'IB32,'IB36 G END
76 ;
77 ; add occ codes from 32 to occ span in 36
78 S IBI=+IBFL(36)+1 F IBI=IBI,IBI+1 I +IB32>0,'IB36,IBI'>(IBPG*2) D
79 . S IBX=+$P(IB32,U,2),IBX=$O(IB32(IBX)) Q:'IBX
80 . S IBY=IB32(IBX)
81 . S $P(IB32,U,1)=+IB32-1
82 . S $P(IB32,U,2)=IBX
83 . S IBX=+IBFL(36)+1
84 . S IBFL(36,IBX)=IBY
85 . S $P(IBFL(36),U,1)=+IBFL(36)+1
86 ;
87 ; add occ span from 36 to occ code in 32
88 S IBI=+IBFL(34)+1 F IBI=IBI,IBI+1 I +IB36>0,'IB32,IBI'>(IBPG*2) D
89 . S IBX=+$P(IB36,U,2),IBX=$O(IB36(IBX)) Q:'IBX
90 . S IBY=IB36(IBX)
91 . S $P(IB36,U,1)=+IB36-1
92 . S $P(IB36,U,2)=IBX
93 . S IBX=+IBFL(34)+1
94 . S IBFL(34,IBX)=$P(IBY,U,1)_U_$P(IBY,U,2),$P(IBFL(34),U,1)=+IBFL(34)+1
95 . S IBFL(35,IBX)=$P(IBY,U,1)_U_$P(IBY,U,3),$P(IBFL(35),U,1)=IBX
96 G OCC
97END ;
98 K IB32,IB36
99 Q
Note: See TracBrowser for help on using the repository browser.