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

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

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1IBCIADD1 ;DSI/SLM - ADD ENTRY TO FILE 351.9 ;17-JAN-2001
2 ;;2.0;INTEGRATED BILLING;**161,203,155**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ADD ;add an entry
6 Q:'IBIFN
7 N FDA,IENS S IBCIADD=1
8 S DIC="^IBA(351.9,",(X,DINUM)=IBIFN,DIC(0)="Z"
9 D FILE^DICN I Y<0 W !!,IBIFN," NOT ADDED TO FILE 351.9" K Y Q
10UPDT ; update an entry
11 I $G(IBCISNT)=7 Q ; esg - 1/3/2002
12 ;
13 ; esg - 3/20/02 - No need to rebuild the 3,4,5 nodes in the event of
14 ; a cancel because we want to send the claim lines that were
15 ; most recently sent to CM, not whatever Vista has now.
16 ; esg - 10/9/02 - However, if the 3,4,5 nodes are not there, then we
17 ; need to rebuild them based on whatever Vista has now.
18 ;
19 I $G(IBCISNT)=4,$P($G(^IBA(351.9,IBIFN,3)),U,1) Q
20 ;
21 D CLEAN^IBCIUT2,DELTI^IBCIUT4
22 NEW IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC
23 S (IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC)=""
24 I '$D(IBCIADD) S IBCIADD=0
25 D INIT1
26 S IENS=IBIFN_","
27 S FDA(351.9,IENS,.02)=IBCIST
28 I $P(^IBA(351.9,IBIFN,0),U,6)']"" D
29 .S FDA(351.9,IENS,.06)=IBCIDE,FDA(351.9,IENS,.07)=IBCIEB
30 S FDA(351.9,IENS,3.01)=IBCIPID,FDA(351.9,IENS,3.02)=IBCIPTLA
31 S FDA(351.9,IENS,3.03)=IBCIPTMI,FDA(351.9,IENS,3.04)=IBCIPTFI
32 S FDA(351.9,IENS,3.05)=IBCIDOB,FDA(351.9,IENS,3.06)=IBCISEX
33 S FDA(351.9,IENS,3.07)=IBCIET
34 ;
35 ; Add referring provider fields
36 S FDA(351.9,IENS,3.08)=IBRFID ; ID
37 S FDA(351.9,IENS,3.09)=IBRFLN ; last name
38 S FDA(351.9,IENS,3.1)=IBRFMN ; middle name
39 S FDA(351.9,IENS,3.11)=IBRFFN ; first name
40 S FDA(351.9,IENS,4.01)=IBRFDEPT ; department
41 S FDA(351.9,IENS,4.02)=IBRFSPEC ; specialty
42 ;
43 D FILE^DIE("K","FDA"),UPDT1^IBCIST
44 ;
45 S IBCILSEG=0 F S IBCILSEG=$O(IBXDATA(IBCILSEG)) Q:'IBCILSEG D
46 .I '$D(^IBA(351.9,IBIFN,5,IBCILSEG)) D ADDSUB
47 .S DR=".06////"_IBCIBDOS(IBCILSEG)_";.02////"_IBCIXLID(IBCILSEG)
48 .S DR=DR_";.03////"_IBCIOGID(IBCILSEG)_";.04////"_IBCIOID(IBCILSEG)
49 .S DR=DR_";.07////"_IBCIEDOS(IBCILSEG)_";.08////"_IBCIPOS(IBCILSEG)
50 .S DR=DR_";.09////"_IBCISPC(IBCILSEG)_";.1////"_IBCIAPC(IBCILSEG)
51 .S DR=DR_";.11////"_IBCISAMT(IBCILSEG)_";.12////"_IBCIPAC(IBCILSEG)
52 .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
53 .S DR=".13////"_IBCISPID(IBCILSEG)_";1.01////"_IBCISPLA(IBCILSEG)
54 .S DR=DR_";1.02////"_IBCISPMI(IBCILSEG)_";1.03////"_IBCISPFI(IBCILSEG)
55 .S DR=DR_";1.04////"_IBCISPTI(IBCILSEG)_";1.05////"_IBCISPDE(IBCILSEG)
56 .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
57 .S DR="1.06////"_IBCISPSP(IBCILSEG)_";1.07////"_IBCISPDI(IBCILSEG)
58 .S DR=DR_";1.08////"_IBCISPUP(IBCILSEG)_";1.09////"_IBCIBPID(IBCILSEG)
59 .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
60 .S DR="2.01////"_IBCIBPLA(IBCILSEG)_";2.02////"_IBCIBPMI(IBCILSEG)
61 .S DR=DR_";2.03////"_IBCIBPFI(IBCILSEG)_";2.04////"_IBCIBPTI(IBCILSEG)
62 .S DR=DR_";2.05////"_IBCIBPDE(IBCILSEG)_";2.06////"_IBCIBPSP(IBCILSEG)
63 .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
64 .S DR="2.07////"_IBCIBPDI(IBCILSEG)_";2.08////"_IBCIBPUP(IBCILSEG)
65 .S DR=DR_";2.09////"_IBCIPPID(IBCILSEG)_";2.1////"_IBCISPAI(IBCILSEG)
66 .S DR=DR_";2.11////"_IBCITOS(IBCILSEG)_";2.12////"_IBCIUNIT(IBCILSEG)
67 .S DR=DR_";3.01////"_IBCICPT(IBCILSEG)
68 .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
69 .Q
70 D CLEAN^IBCIUT2 K IBCIADD
71 Q
72 ;
73INIT1 ; Initialize variables for adding entry in 351.9
74 NEW IBZ,IBPRV
75 S IBCIDFN=$P(^DGCR(399,IBIFN,0),U,2)
76 S IBCICL=$P(^DGCR(399,IBIFN,0),U)
77 S IBCIST=$S(IBCIADD=1:1,1:$P(^IBA(351.9,IBIFN,0),U,2)),IBCIEB=DUZ
78 S (IBCIDE,IBCIET)=$$NOW^XLFDT
79 S IBCIPID=$P(^DPT(IBCIDFN,0),U,9)
80 S X=$P(^DPT(IBCIDFN,0),U) D NAMSP^IBCIUT1
81 S IBCIPTLA=$P(Y,U,1),IBCIPTFI=$P(Y,U,2),IBCIPTMI=$P(Y,U,3)
82 S IBCIDOB=$P(^DPT(IBCIDFN,0),U,3),IBCISEX=$P(^DPT(IBCIDFN,0),U,2)
83 ;
84 ; capture referring provider information
85 D GETPRV^IBCEU(IBIFN,1,.IBZ) ; "1" signifies referring provider
86 S IBZ=$G(IBZ(1,1))
87 I IBZ'="" D
88 . S IBPRV=$P(IBZ,U,3)
89 . S IBRFLN=$$NAME^IBCEFG1($P(IBZ,U,1)),IBRFMN=$P(IBRFLN,U,3),IBRFFN=$P(IBRFLN,U,2),IBRFLN=$P(IBRFLN,U,1)
90 . S IBRFSPEC=$$BILLSPEC^IBCEU3(IBIFN,IBPRV) ; ref prov specialty
91 . I IBPRV'["IBA(355.93" D ; va provider data
92 .. S IBRFID=+IBPRV
93 .. S IBRFDEPT=$P($G(^VA(200,+IBPRV,5)),U,1)
94 .. Q
95 . I IBPRV["IBA(355.93" D ; non-va provider data
96 .. S IBRFID="NVA"_+IBPRV
97 .. S IBRFDEPT="NVA"
98 .. Q
99 . Q
100 ;
101 ;initialize variables for line items in 351.9 and save
102 D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN)
103 S IBCILSEG=0
104 F S IBCILSEG=$O(IBXDATA(IBCILSEG)) Q:'IBCILSEG D
105 . NEW CURRENT,DIV
106 . S X=$P(IBXDATA(IBCILSEG),U),IBCIBDOS(IBCILSEG)=$$NOW1^IBCIUT1(X)
107 . I $P(IBXDATA(IBCILSEG),U,2)]"" S X=$P(IBXDATA(IBCILSEG),U,2),IBCIEDOS(IBCILSEG)=$$NOW1^IBCIUT1(X)
108 . I $P(IBXDATA(IBCILSEG),U,2)']"" S IBCIEDOS(IBCILSEG)=IBCIBDOS(IBCILSEG)
109 . S IBCIPOS(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,3)
110 . S IBCITOS(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,4)
111 . S IBCISPC(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,5)
112 . S IBCISAMT(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,8)
113 . S IBCIUNIT(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,9)
114 . S IBCICPT(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,10)
115 . S IBCICPT(IBCILSEG)=$$GETMOD^IBCIUT5(IBCICPT(IBCILSEG))
116 . I IBCIUNIT(IBCILSEG)>1 S IBCISAMT(IBCILSEG)=IBCISAMT(IBCILSEG)*IBCIUNIT(IBCILSEG)
117 . S IBCIAPC(IBCILSEG)="",IBCIXLID(IBCILSEG)=IBCILSEG
118 . S IBCIOGID(IBCILSEG)="",IBCIOID(IBCILSEG)="",IBCIPAC(IBCILSEG)=""
119 . ;
120 . ; capture the default division (field# .22) for the organization id
121 . S DIV=$P($G(^DGCR(399,IBIFN,0)),U,22)
122 . I DIV S IBCIOID(IBCILSEG)=$P($G(^DG(40.8,DIV,0)),U,2)
123 . ;
124 . ; Billing provider information
125 . S IBXDAT1=$$RPHY^IBCIUT1(IBIFN) ; Get provider information
126 . S IBCIBPID(IBCILSEG)=$P(IBXDAT1,U,2) ; provider ID
127 . S X=$P(IBXDAT1,U,1) D NAMSP^IBCIUT1 ; parse full provider name
128 . S IBCIBPLA(IBCILSEG)=$P(Y,U,1) ; provider last name
129 . S IBCIBPFI(IBCILSEG)=$P(Y,U,2) ; provider first name
130 . S IBCIBPMI(IBCILSEG)=$P(Y,U,3) ; provider middle name
131 . S IBCIBPDE(IBCILSEG)=$P(IBXDAT1,U,3) ; provider department
132 . S IBCIBPSP(IBCILSEG)=$P(IBXDAT1,U,4) ; provider specialty
133 . S IBCIBPDI(IBCILSEG)="" ; provider degree ID
134 . S IBCIBPTI(IBCILSEG)="" ; provider title
135 . S IBCIBPUP(IBCILSEG)="" ; provider UPIN
136 . KILL X,Y ; clean up
137 . ;
138 . ; Primary payer ID
139 . S IBCIPPID(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN)
140 . ;
141 . ; Get the secondary payer ID based on the current bill sequence
142 . ;
143 . S IBCISPAI(IBCILSEG)=""
144 . S CURRENT=$$COB^IBCEF(IBIFN)
145 . I CURRENT="P" S IBCISPAI(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN,"S")
146 . I CURRENT="S" S IBCISPAI(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN,"T")
147 . ;
148 . S IBCISPID(IBCILSEG)="",IBCISPLA(IBCILSEG)="",IBCISPFI(IBCILSEG)=""
149 . S IBCISPMI(IBCILSEG)="",IBCISPTI(IBCILSEG)="",IBCISPDE(IBCILSEG)=""
150 . S IBCISPSP(IBCILSEG)="",IBCISPDI(IBCILSEG)="",IBCISPUP(IBCILSEG)=""
151 . Q
152 Q
153 ;
154ADDSUB ;create the subfile
155 S DIC="^IBA(351.9,"_IBIFN_",5,",DA(1)=IBIFN,DIC(0)="LMN",(DA,X)=IBCILSEG
156 D FILE^DICN
157 Q
Note: See TracBrowser for help on using the repository browser.