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

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

initial load of WorldVistAEHR

File size: 5.5 KB
Line 
1IBBACHRG ;OAK/ELZ - PFSS CHARGE 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 ;
5CHARGE(IBBDFN,IBBARFN,IBBCTYPE,IBBUCID,IBBFT1,IBBPR1,IBBDG1,IBBZCL,IBBRXE,IBBORIEN,IBBPROS) ;
6 ;add transaction to charge cache
7 N IBB,IBBIEN,IBBIENS,IBBERR,FDA,J,J1,X,XX
8 N IBBCPTC,IBBCPTDT,IBBCDM,IBBSECVN,IBBTEST
9 ;required parameters
10 I ('$G(IBBDFN)!'$G(IBBARFN)!'$G(IBBUCID)!($G(IBBCTYPE)="")) D ERRMSG("MISSING DATA") Q 0
11 ;add charge record
12 L +^IBBAD(373,0):5
13 I '$T D ERRMSG("LOCK FAILURE") Q 0
14 S IBBIEN=$P(^IBBAD(373,0),U,3)+1,$P(^IBBAD(373,0),U,3)=IBBIEN
15 L -^IBBAD(373,0)
16 S ^IBBAD(373,IBBIEN,0)=IBBIEN
17 S IBBIENS=IBBIEN_","
18 S IBBERR="IBB(""DIERR"")"
19 S FDA(373,IBBIENS,.02)=IBBARFN
20 S FDA(373,IBBIENS,.03)=IBBDFN
21 S FDA(373,IBBIENS,.04)=IBBUCID
22 S FDA(373,IBBIENS,.05)=IBBCTYPE
23 S FDA(373,IBBIENS,.1)=$$NOW^XLFDT()
24 D FILE^DIE("","FDA",IBBERR)
25 ;exit on error
26 I $D(IBB("DIERR")) D ERRMSG("FILEMAN ERROR") Q 0
27 ;get service charge code
28 S IBBCDM=$G(IBBFT1(7))
29 I $G(IBBFT1(13))'=160 D
30 .S IBBCPTC=+$G(IBBPR1(3))
31 .S IBBCPTDT=+$G(IBBPR1(5)) I 'IBBCPTDT S IBBCPTDT=+$G(IBBFT1(4))
32 .S IBBCDM=$P($$GETCODE^IBBACDM(IBBCPTC,IBBCPTDT),U,1)
33 ;financial transaction
34 I $D(IBBFT1)>1 D
35 .S J=0,X="" F S J=$O(IBBFT1(J)) Q:'J S $P(X,U,J)=IBBFT1(J)
36 .S $P(X,U,2)="",$P(X,U,6)=IBBCTYPE
37 .S XX=+$G(IBBFT1(13)) S XX=$S('XX:999,$L(XX)'=3:999,1:XX)
38 .S $P(X,U,7)=XX_IBBCDM
39 .S ^IBBAD(373,IBBIEN,"FT1")=X
40 ;update PV1.50 for radiology in file #375
41 I (",105,109,115,150,151,152,421,703,")[(","_IBBFT1(13)_",") D
42 .S XX="",IBBSECVN=""
43 .I $G(IBBORIEN) S X=$T(ORACTREF^ORWPFSS) I $E(X,9)="(" D
44 ..D ORACTREF^ORWPFSS(.XX,IBBORIEN)
45 ..S IBBSECVN=$$EXTNUM^IBBAACCT(IBBDFN,XX)
46 ..I IBBSECVN'="" S $P(^IBBAA(375,IBBARFN,"PV1"),U,50)=IBBSECVN_";;;;RAD"
47 ;procedure
48 I $D(IBBPR1)>1 D
49 .I '$G(IBBPR1(5)) S IBBPR1(5)=+$G(IBBFT1(4))
50 .S X="" F J=3,5,6,16 S $P(X,U,J)=$G(IBBPR1(J))
51 .;surgery-only
52 .I $D(IBBPR1(11))>1 D
53 ..S $P(X,U,11)=$G(IBBPR1(11,1)),$P(X,U,12)=$G(IBBPR1(11,2))
54 .S ^IBBAD(373,IBBIEN,"PR1")=X
55 .I $G(IBBPR1(4))'="" S ^IBBAD(373,IBBIEN,11)=IBBPR1(4)
56 ;diagnosis
57 I $D(IBBDG1)>1 D
58 .I $G(IBBDG1(1,3))=+$G(IBBDG1(1,3)) D DX^IBBACHRG(.IBBDG1,IBBIEN)
59 ;classification
60 I $D(IBBZCL)>1 D
61 .S (J,J1)=0 F S J=$O(IBBZCL(J)) Q:'J S J1=J1+1,X=J1_U_$G(IBBZCL(J,2))_U_$G(IBBZCL(J,3)),^IBBAD(373,IBBIEN,"ZCL",J1,0)=X
62 .S ^IBBAD(373,IBBIEN,"ZCL",0)="^373.05A^"_J1_U_J1
63 ;pharmacy-only
64 I $D(IBBRXE)>1 D
65 .S J=0,X="" F S J=$O(IBBRXE(J)) Q:'J S $P(X,U,J)=IBBRXE(J)
66 .S XX=$P(^IBBAA(375,IBBARFN,"PV1"),U,50) I $P(XX,";",5)="OPP" S XX=+XX,$P(X,U,15)=XX
67 .S ^IBBAD(373,IBBIEN,"RXE")=X
68 ;prosthetics-only
69 I $D(IBBPROS)>1 D
70 .S X=$G(IBBPROS(1))_U_$G(IBBPROS(2))
71 .I X'=U S ^IBBAD(373,IBBIEN,23)=X
72 ;add department, service code, order ien, clinical event id to 0-node
73 S X=^IBBAD(373,IBBIEN,0)
74 S $P(X,U,6)=$S($G(IBBFT1(13)):IBBFT1(13),1:999),$P(X,U,7)=$G(IBBCDM),$P(X,U,8)=$G(IBBORIEN),$P(X,U,9)=$G(IBBFT1(2))
75 S ^IBBAD(373,IBBIEN,0)=X
76 ;set "AOX" xref
77 S IBBTEST="" D SAOX^IBBAADD(IBBIEN,IBBDFN,.IBBTEST)
78 I IBBTEST S $P(^IBBAD(373,IBBIEN,0),U,20)=1
79 ;
80 Q 1
81 ;
82DX(DG1,IEN) ;file diagnosis on subfile #373.04
83 N J,IBB,IBBIEN,IBBIENS,IBBERR,FDA
84 S J=0 F S J=$O(DG1(J)) Q:'J Q:(DG1(J,3)'=+DG1(J,3)) D
85 .S IBBIEN(1)=J
86 .S IBBIENS="+1,"_IEN_","
87 .S IBBERR="IBB(""DIERR"")"
88 .S FDA(373.04,IBBIENS,.01)=J
89 .S FDA(373.04,IBBIENS,.03)=DG1(J,3)
90 .S FDA(373.04,IBBIENS,.06)=$G(DG1(J,6))
91 .D UPDATE^DIE("","FDA","IBBIEN",IBBERR)
92 Q
93 ;
94GETCHGID() ;
95 ;get next unique charge identifier
96 N X
97 L +^IBBAS(372,1,2):5
98 Q:'$T 0
99 S X=1+$G(^IBBAS(372,1,2))
100 I X>99999999 S X=1
101 S ^IBBAS(372,1,2)=X
102 L -^IBBAS(372,1,2)
103 Q X
104 ;
105ERRMSG(MSG) ;generate error msg if charge failure
106 N LINE,J,X
107 S LINE=0,SETLN="S LINE=LINE+1,^TMP(""PFSS CHG ERROR"",$J,LINE,0)=X"
108 I MSG="MISSING DATA" D
109 .I '$G(IBBDFN) S MSG=MSG_": DFN" Q
110 .I '$G(IBBARFN) S MSG=MSG_": PFSS Account Reference" Q
111 .I '$G(IBBUCID) S MSG=MSG_": Unique Charge ID" Q
112 .I $G(IBBCTYPE)="" S MSG=MSG_": Charge Type" Q
113 I MSG="FILEMAN ERROR" D
114 .I $D(IBB("DIERR")) S MSG="FM ERROR: "_$G(IBB("DIERR","DIERR",1,"TEXT",1))
115 I MSG="LOCK FAILURE" S MSG="Lock request failure on ^IBBAD(373,0)"
116 S X=MSG X SETLN
117 S X=" " X SETLN
118 S X="Input Parameters" X SETLN
119 S X="----------------" X SETLN
120 S X="IBBDFN="_$G(IBBDFN) X SETLN
121 S X="IBBARFN="_$G(IBBARFN) X SETLN
122 S X="IBBCTYPE="_$G(IBBCTYPE) X SETLN
123 S X="IBBUCID="_$G(IBBUCID) X SETLN
124 I $D(IBBFT1)>1 D
125 .S J=0 F S J=$O(IBBFT1(J)) Q:'J S X="IBBFT1("_J_")="_IBBFT1(J) X SETLN
126 I $D(IBBPR1)>1 D
127 .S J=0 F S J=$O(IBBPR1(J)) Q:'J I J'=11 S X="IBBPR1("_J_")="_IBBPR1(J) X SETLN
128 .I $G(IBBPR1(11,1)) S X="IBBPR1(11,1)="_IBBPR1(11,1) X SETLN
129 .I $G(IBBPR1(11,2)) S X="IBBPR1(11,2)="_IBBPR1(11,2) X SETLN
130 I $D(IBBDG1)>1 D
131 .S J=0 F S J=$O(IBBDG1(J)) Q:'J S J1=0 F S J1=$O(IBBDG1(J,J1)) Q:'J1 S X="IBBDG1("_J_","_J1_")="_IBBDG1(J,J1) X SETLN
132 I $D(IBBZCL)>1 D
133 .S J=0 F S J=$O(IBBZCL(J)) Q:'J S J1=0 F S J1=$O(IBBZCL(J,J1)) Q:'J1 S X="IBBZCL("_J_","_J1_")="_IBBZCL(J,J1) X SETLN
134 I $D(IBBRXE)>1 D
135 .S J=0 F S J=$O(IBBRXE(J)) Q:'J S X="IBBRXE("_J_")="_IBBRXE(J) X SETLN
136 I $G(IBBORIEN) S X="IBBORIEN="_IBBORIEN X SETLN
137 I $D(IBBPROS)>1 D
138 .S J=0 F S J=$O(IBBPROS(J)) Q:'J S X="IBBPROS("_J_")="_IBBPROS(J) X SETLN
139 D MAIL
140 Q
141 ;
142MAIL ;send error message to mail group
143 N MMGROUP,IENS,XMY,XMSUB,XMDUZ,XMTEXT,XMZ
144 S XMSUB="IBB CHARGE FAILURE at "_$$NOW^XLFDT(),XMDUZ=.5
145 S MMGROUP=$P($G(^IBBAS(372,1,0)),U,6)
146 I MMGROUP D
147 .S IENS=MMGROUP_","
148 .S MMGROUP=$$GET1^DIQ(3.8,IENS,.01)
149 .S XMY("G."_MMGROUP_"@"_^XMB("NETNAME"))=""
150 S XMTEXT="^TMP(""PFSS CHG ERROR"",$J,"
151 D ^XMD
152 K ^TMP("PFSS CHG ERROR",$J)
153 Q
Note: See TracBrowser for help on using the repository browser.