source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBBAACCT.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: 5.7 KB
Line 
1IBBAACCT ;OAK/ELZ - PFSS ACCOUNT API ;15-MAR-2005
2 ;;2.0;INTEGRATED BILLING;**286**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5GET(IBBDFN,IBBARFN,IBBEVENT,IBBAPLR,IBBPV1,IBBPV2,IBBPR1,IBBDG1,IBBZCL,IBBDIV,IBBRAIEN,IBBSURG) ;
6 ;
7 N IBB,IBBIEN,IBBIENS,IBBERR,IBBVERR,IBBSUBTY,IBBVDEF,FDA,OUT,J,J1,X,Y,X1,X2,X3
8 I '$G(IBBDFN)!($G(IBBEVENT)="") Q 0
9 I $D(IBBPV1)<10 Q 0
10 ;
11 ;update account record
12 S OUT=0
13 I IBBARFN'="" D
14 .S IBBIEN=IBBARFN
15 .I IBBDFN'=$P($G(^IBBAA(375,IBBIEN,0)),U,3) S OUT=1 Q
16 .;visit data
17 .I $D(IBBPV1)>1 D
18 ..I $G(IBBPV1(44))="" S IBBPV1(44)=$G(IBBPV2(8))
19 ..I $P($G(^IBBAA(375,IBBIEN,"PV1")),U,44),$G(IBBPV1(44))'=$P($G(^IBBAA(375,IBBIEN,"PV1")),U,44),$P(^IBBAA(375,IBBIEN,0),U,2) D KAC144^IBBAADD(IBBIEN)
20 ..S J=0 F S J=$O(IBBPV1(J)) Q:'J S $P(^IBBAA(375,IBBIEN,"PV1"),U,J)=IBBPV1(J)
21 ..I $G(IBBPV1(50)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBPV1(50)_";;;;OPP"
22 .I $D(IBBPV2)>1 D
23 ..S J=0 F S J=$O(IBBPV2(J)) Q:'J S $P(^IBBAA(375,IBBIEN,"PV2"),U,J)=IBBPV2(J)
24 .;procedure
25 .I $D(IBBPR1)>1 D
26 ..S J=0,X="" F S J=$O(IBBPR1(J)) Q:'J I J'=4 S $P(X,U,J)=IBBPR1(J)
27 ..S ^IBBAA(375,IBBIEN,"PR1")=X
28 ..I $G(IBBPR1(4))'="" S ^IBBAA(375,IBBIEN,11)=IBBPR1(4)
29 .;diagnosis
30 .;if any dx sent, remove existing dx
31 .I $D(IBBDG1)>1,$G(IBBDG1(1,3))=+$G(IBBDG1(1,3)) K ^IBBAA(375,IBBIEN,"DG1") D DX^IBBAACCT(.IBBDG1,IBBIEN)
32 .I $G(IBBDG1(1,4)) S ^IBBAA(375,IBBIEN,12)=IBBDG1(1,4)
33 .;classification
34 .;if any classification sent, remove existing classification
35 .I $D(IBBZCL)>1 D
36 ..K ^IBBAA(375,IBBIEN,"ZCL")
37 ..S (J,J1)=0 F S J=$O(IBBZCL(J)) Q:'J S J1=J1+1,X=J1_U_IBBZCL(J,2)_U_IBBZCL(J,3),^IBBAA(375,IBBIEN,"ZCL",J1,0)=X
38 ..S ^IBBAA(375,IBBIEN,"ZCL",0)="^375.05A^"_J1_U_J1
39 .;miscellaneous
40 .I $G(IBBDIV) S ^IBBAA(375,IBBIEN,13)=IBBDIV
41 .I $D(IBBSURG)>1 S ^IBBAA(375,IBBIEN,14)=$G(IBBSURG(1))_U_$G(IBBSURG(2))
42 .I $G(IBBRAIEN) S ^IBBAA(375,IBBIEN,15)=$G(IBBRAIEN)
43 .I $G(IBBSURG(1)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBSURG(1)_";;;;SUR"
44 I OUT Q 0
45 ;
46 ;request account reference number
47 I IBBARFN="" D
48 .I $G(IBBAPLR)'="" D
49 ..S IBBAPLR=$E($TR(IBBAPLR,U,";"),1,25)
50 ..I IBBAPLR'[";" S IBBAPLR=";"_IBBAPLR
51 .L +^IBBAA(375,0):5
52 .Q:'$T
53 .S IBBIEN=$P(^IBBAA(375,0),U,3)+1,$P(^IBBAA(375,0),U,3)=IBBIEN
54 .L -^IBBAA(375,0)
55 .S ^IBBAA(375,IBBIEN,0)=IBBIEN
56 .S IBBIENS=IBBIEN_","
57 .S IBBERR="IBB(""DIERR"")"
58 .S FDA(375,IBBIENS,.02)="G"
59 .S FDA(375,IBBIENS,.03)=IBBDFN
60 .S FDA(375,IBBIENS,.04)=$G(IBBAPLR)
61 .D FILE^DIE("","FDA",IBBERR)
62 .Q:$D(IBB("DIERR"))
63 .S IBBARFN=IBBIEN
64 .;visit data
65 .I $D(IBBPV1)>1 D
66 ..I $G(IBBPV1(44))="" S IBBPV1(44)=$G(IBBPV2(8))
67 ..S J=0,X="" F S J=$O(IBBPV1(J)) Q:'J S $P(X,U,J)=IBBPV1(J)
68 ..S ^IBBAA(375,IBBIEN,"PV1")=X
69 ..I $G(IBBPV1(50)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBPV1(50)_";;;;OPP"
70 ..I $G(IBBPV1(3))="FEE BASIS" D
71 ...S IBBPV1(44)=$P($G(IBBPV1(44)),".",1)
72 ...S $P(^IBBAA(375,IBBIEN,"PV1"),U,3)="",$P(^("PV1"),U,44)=IBBPV1(44)
73 ...S ^IBBAA(375,IBBIEN,16)=IBBPV1(3)
74 .I $D(IBBPV2)>1 D
75 ..S J=0,X="" F S J=$O(IBBPV2(J)) Q:'J S $P(X,U,J)=IBBPV2(J)
76 ..S ^IBBAA(375,IBBIEN,"PV2")=X
77 .;procedure
78 .I $D(IBBPR1)>1 D
79 ..I $D(IBBPR1(4)) S ^IBBAA(375,IBBIEN,11)=IBBPR1(4)
80 ..S J=0,X="" F S J=$O(IBBPR1(J)) Q:'J I J'=4 S $P(X,U,J)=IBBPR1(J)
81 ..S ^IBBAA(375,IBBIEN,"PR1")=X
82 .;diagnosis
83 .I $D(IBBDG1)>1 D
84 ..I $D(IBBDG1(1,4)) S ^IBBAA(375,IBBIEN,12)=IBBDG1(1,4)
85 ..I $G(IBBDG1(1,3))=+$G(IBBDG1(1,3)) D DX^IBBAACCT(.IBBDG1,IBBIEN)
86 .;classification
87 .I $D(IBBZCL)>1 D
88 ..S (J,J1)=0 F S J=$O(IBBZCL(J)) Q:'J S J1=J1+1,X=J1_U_IBBZCL(J,2)_U_IBBZCL(J,3),^IBBAA(375,IBBIEN,"ZCL",J1,0)=X
89 ..S ^IBBAA(375,IBBIEN,"ZCL",0)="^375.05A^"_J1_U_J1
90 .;miscellaneous
91 .I $G(IBBDIV) S ^IBBAA(375,IBBIEN,13)=IBBDIV
92 .I $D(IBBSURG)>1 S ^IBBAA(375,IBBIEN,14)=$G(IBBSURG(1))_U_$G(IBBSURG(2))
93 .I $G(IBBRAIEN) S ^IBBAA(375,IBBIEN,15)=$G(IBBRAIEN)
94 .I $G(IBBSURG(1)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBSURG(1)_";;;;SUR"
95 ;
96 ;exit here if lock failed or FM error (??)
97 I 'IBBARFN Q +IBBARFN
98 ;
99 ;update event history
100 I $L(IBBEVENT)=3 D EVENT^IBBAACCT(IBBARFN,IBBEVENT,"R")
101 ;
102 ;set xref
103 S X1=IBBDFN,X2=$G(IBBPV1(3)),X3=$G(IBBPV1(44)) I X3 D
104 .I X2'=+X2 S ^IBBAA(375,"AF",X1,X3,X2,IBBARFN)=""
105 .I X2=+X2 S ^IBBAA(375,"AC",X1,X3,X2,IBBARFN)=""
106 ;
107 ;quit if test patient
108 I $$TESTPAT^VADPT(IBBDFN) S $P(^IBBAA(375,IBBIEN,0),U,20)=1 Q IBBARFN
109 ;
110 ;call VDEF
111 S IBBVDEF=0,X=IBBEVENT
112 S IBBSUBTY=$S(X="A01":"PFAN",X="A03":"PFDE",X="A04":"PFOA",X="A05":"PFPA",X="A08":"PFUPI",X="A11":"PFCAN",X="A13":"PFCDE",X="A38":"PFCPA",1:"")
113 I IBBSUBTY'="" S X=$T(QUEUE^VDEFQM) I X'="" S IBBVDEF=$$QUEUE^VDEFQM("ADT^"_IBBEVENT,"SUBTYPE="_IBBSUBTY_"^IEN="_IBBARFN,.IBBVERR,"PFSS OUTBOUND")
114 ;
115 Q +IBBARFN
116 ;
117DX(DG1,IEN) ;file diagnosis on subfile #375.04
118 N J,IBB,IBBIEN,IBBIENS,IBBERR,FDA
119 S J=0 F S J=$O(DG1(J)) Q:'J Q:(DG1(J,3)'=+DG1(J,3)) D
120 .S IBBIEN(1)=J
121 .S IBBIENS="+1,"_IEN_","
122 .S IBBERR="IBB(""DIERR"")"
123 .S FDA(375.04,IBBIENS,.01)=J
124 .S FDA(375.04,IBBIENS,.03)=DG1(J,3)
125 .S FDA(375.04,IBBIENS,.06)=$G(DG1(J,6))
126 .D UPDATE^DIE("","FDA","IBBIEN",IBBERR)
127 Q
128 ;
129EVENT(IBBARFN,IBBEVENT,IBBREAS,IBBHLMSG) ;update the event history subfile #375.099
130 ;
131 ;update event history
132 N IBB,IBBIEN,IBBIENS,IBBERR,FDA
133 Q:'$G(IBBARFN) Q:$G(IBBEVENT)=""
134 S IBBIEN(1)=""
135 S IBBIENS="+1,"_IBBARFN_","
136 S IBBERR="IBB(""DIERR"")"
137 S FDA(375.099,IBBIENS,.01)=$$NOW^XLFDT()
138 S FDA(375.099,IBBIENS,.02)=IBBEVENT
139 S FDA(375.099,IBBIENS,.03)=$G(IBBREAS)
140 S FDA(375.099,IBBIENS,.04)=$G(IBBHLMSG)
141 D UPDATE^DIE("","FDA","IBBIEN",IBBERR)
142 Q
143 ;
144EXTNUM(IBBDFN,IBBARFN) ;find external visit number
145 N IBBIEN,IBBEXVN,IBBARRY,IBBERR
146 S IBBEXVN="",IBBIEN=IBBARFN
147 D GETS^DIQ(375,IBBIEN_",",".02;.03","I","IBBARRY","IBBERR")
148 I $D(IBBERR("DIERR")) Q IBBEXVN
149 I IBBARRY(375,IBBIEN_",",.03,"I")=IBBDFN S IBBEXVN=IBBARRY(375,IBBIEN_",",.02,"I")
150 Q IBBEXVN
Note: See TracBrowser for help on using the repository browser.