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

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

initial load of WorldVistAEHR
File size: 9.4 KB
RevLine 
[613]1IBARXMI ;OAK/ELZ-HL7 RECEIVER FOR PFSS WORKING ROUTINE ;6-APR-2005
2 ;;2.0;INTEGRATED BILLING;**308**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5QUERYVA ; called by HL7 receiver to send queries out to all sites of record
6 ; for the given patient to look for updated copay cap information.
7 ; TYPE = ST
8 ;
9 N IBADT,IBRX,X,IBX,IBQ
10 ;
11 ;check out data received from message (need to get rx/fill number that caused this)
12 S IBQ=0 F IBX=.091,.092,.03 I $G(IB35471(IBX))="" S IBQ=1 Q
13 I IBQ S HLERR="354.71 field "_IBX_" missing" Q
14 S IBRX=$O(^PSRX("B",IB35471(.091),0)) I 'IBRX S HLERR="Rx number not found" Q
15 I '$D(^PSRX(+IBRX,1,IB35471(.092),0)),IB35471(.092) S HLERR="Refill invalid or not found" Q
16 ;
17 ; set DUZ to pharmacy person who caused this to occur DBIA4732 and SACC exemption
18 D
19 . I $G(DUZ)<1,$L($T(RPH^PSOPFSU0)) N DUZ S DUZ=$P($$RPH^PSOPFSU0(IB35471(.091),IB35471(.092)),"^",2),DUZ(2)=+$$SITE^VASITE
20 . ;
21 . ; call to do query
22 . S IBADT=IB35471(.03)
23 . D BBE^IBARXPFS
24 ;
25 ; call vdef to say done
26 S X=$$QUEUE^VDEFQM("DFT^P03","SUBTYPE=CPFI^IEN="_DFN,,"PFSS OUTBOUND")
27 ;
28 Q
29 ;
30BILLVA ; called by HL7 receiver to initiate back billing at a remote VA site.
31 ; TYPE = BL
32 ;
33 N IBX,IBRX,IBQ
34 ;
35 ;check out data received from message
36 S IBQ=0 F IBX=.01,.11,.091,.092 I $G(IB35471(IBX))="" S IBQ=1 Q
37 I IBQ S HLERR="354.71 field "_IBX_" missing" Q
38 I IB35471(.11)<.01 S HLERR="Invalid amount to back bill" Q
39 S IBX=$O(^IBAM(354.71,"B",IB35471(.01),0)) I 'IBX S HLERR="Invalid 354.71 transaction number" Q
40 S IBRX=$O(^PSRX("B",IB35471(.091),0)) I 'IBRX S HLERR="Rx number not found" Q
41 I '$D(^PSRX(+IBRX,1,IB35471(.092),0)),IB35471(.092) S HLERR="Refill invalid or not found" Q
42 ;
43 ;need to set DUZ to pharmacy staff person who caused this to occur DBIA4732 and SACC exemption
44 D
45 . I $G(DUZ)<1,$L($T(RPH^PSOPFSU0)) N DUZ S DUZ=$P($$RPH^PSOPFSU0(IBRX,IB35471(.092)),"^",2),DUZ(2)=+$$SITE^VASITE
46 . ;
47 . ;call remote site to do back billing for specified $ amount
48 . I +IB35471(.01)'=$P($$SITE^VASITE,"^",3) D SEND^IBARXMB(IB35471(.01),IB35471(.11)) Q
49 . I +IB35471(.01)=$P($$SITE^VASITE,"^",3),'$P(^IBAM(354.71,IBX,0),"^",20) D BILL^IBARXMB(IB35471(.01),IB35471(.11)) Q
50 . S HLERR="Transaction from local VistA or remote VA site"
51 ;
52 Q
53 ;
5435471 ; files data into 354.71 (TYPE = IN)
55 ; validate data
56 N IBX,IBQ,IBRX,IBARXDAT,IBATYP,IBAM,IBDESC
57 I '$L($T(RPH^PSOPFSU0)) S HLERR="Pharmacy API not installed" Q
58 S IBQ=0 F IBX=.01,.03,.05,.07,.08,.091,.1,.11,.12 I $G(IB35471(IBX))="" S IBQ=1 Q
59 I IBQ S HLERR="354.71 field "_IBX_" missing" Q
60 ;
61 I $P($$SITE^VASITE,"^",3)'=+IB35471(.01)!(IB35471(.01)'?3N1"-"1N.N) S HLERR="354.71 field .01 invalid" Q
62 I $P($$SITE^VASITE,"^",3)'=+IB35471(.1)!(IB35471(.1)'?3N1"-"1N.N) S HLERR="354.71 field .1 invalid" Q
63 I IB35471(.1)'=IB35471(.01),$O(^IBAM(354.71,"B",IB35471(.1),0)) S HLERR="354.71 field .1 is not a valid parent" Q
64 F IBX=.08,.11,.12 S IB35471(IBX)=+IB35471(IBX)
65 I 'IB35471(.08) S HLERR="Total Charge in-valid" Q
66 S IBRX=$O(^PSRX("B",IB35471(.091),0)) I 'IBRX S HLERR="Invalid prescription number" Q
67 I IB35471(.092),'$D(^PSRX(IBX,1,IB35471(.092),0)) S HLERR="Invalid fill/refill number" Q
68 F IBX=.01,.03,.05,.07,.08,.11,.12 D CHK^DIE(354.71,IBX,,IB35471(IBX),.IBQ) I IBQ="^" S HLERR="File 354.71, field "_IBX_" does not pass DD check" Q
69 ;
70 ;look up some needed rx data
71 S IBARXDAT=$$RPH^PSOPFSU0(IBRX,+IB35471(.092))
72 I $P(IBARXDAT,"^",3)="" S HLERR="Bad prescription data" Q
73 ;
74 ;get brief description
75 S IBX="52:"_IBRX_$S(IB35471(.092):";1:"_IB35471(.092),1:"")_"^"_IB35471(.07)
76 D ELIG^VADPT,INP^VADPT,DOM^IBARX
77 S IBATYP=$O(^IBE(350.1,"ANEW",$P(IBARXDAT,"^",3),1,0))
78 D BDESC^IBARX1
79 ;
80 ;need to set DUZ to pharmacy staff person who caused this to occur
81 D
82 . I $G(DUZ)<1 N DUZ S DUZ=$S(IB35471(.05)="NEW":$P(IBARXDAT,"^"),1:$P(IBARXDAT,"^",2)),DUZ(2)=+$$SITE^VASITE
83 . N DIE,DR,DA
84 . ;
85 . ;file in 354.71
86 . S IBAM=$$ADD^IBARXMN(DFN,IB35471(.01)_"^"_DFN_"^"_IB35471(.03)_"^^"_IB35471(.05)_"^"_$P(IBX,"^")_"^"_IB35471(.07)_"^"_IB35471(.08)_"^"_IBDESC_"^"_IB35471(.1)_"^"_IB35471(.11)_"^"_IB35471(.12)_"^"_$$LKUP^XUAF4(+IB35471(.01)),,1)
87 . S DIE="^IBAM(354.71,",DA=IBAM,DR=".2////1" D ^DIE
88 . ;
89 . ;call to send data to remote sites
90 . D FOUND^IBARXMA(.IBX,IBAM)
91 ;
92 D KVA^VADPT
93 ;
94 Q
95 ;
96351 ; files data in 351 (MT type)
97 ;
98 N IBQ,IBX,DIC,DIE,DR,X,Y,DA,DO
99 ;
100 ;validate data
101 S IBQ=0 F IBX=.03,.04,.05,.06,.07,.08,.09,.1 I $G(IB351(IBX))="" S IBQ=1 Q
102 I IBQ S HLERR="351 field "_IBX_" missing" Q
103 I '$G(IB35471(.01)) S HLERR="Clock file number missing or invalid" Q
104 S IB351(.01)=IB35471(.01)
105 F IBX=.01,.03,.04,.05,.06,.07,.08,.09,.1 D CHK^DIE(351,IBX,,IB351(IBX),.IBQ) I IBQ="^" S HLERR="File 351, field "_IBX_" does not pass DD check" Q
106 ;
107 ; see if clock already exists or add
108 S IBX=$O(^IBE(351,"B",IB35471(.01),0))
109 I 'IBX S DIC="^IBE(351,",X=IB351(.01),DIC(0)="",DIC("DR")=".02////^S X=DFN;11////"_$S($D(DUZ):DUZ,1:.5)_";12///NOW;13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW" K DO D FILE^DICN S IBX=+Y
110 I DFN'=$P($G(^IBE(351,IBX,0)),"^",2) S HLERR="Patient does not match clock file entry" Q
111 ;
112 ; file data received
113 S DIE="^IBE(351,",DA=IBX,DR=".04///^S X=IB351(.04);13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW" F X=.03,.05,.06,.07,.08,.09,.1 S DR=DR_";"_X_"////"_+IB351(X)
114 D ^DIE
115 Q
116 ;
11735181 ; files data in 351.81 (LB type)
118 ;
119 N IBQ,IBX,DIC,DIE,DR,X,Y,IBY,DA,DO,DIK,IBLTCX
120 ;
121 ;validate data
122 S IBQ=0 F IBX=.03,.04,.05 I $G(IB35181(IBX))="" S IBQ=1 Q
123 I IBQ S HLERR="351.81 field "_IBX_" missing" Q
124 I '$G(IB35471(.01)) S HLERR="LTC Clock file number missing or invalid" Q
125 S IB35181(.01)=IB35471(.01)
126 F IBX=.01,.03,.04,.05 D CHK^DIE(351.81,IBX,,IB35181(IBX),.IBQ) I IBQ="^" S HLERR="File 351.81, field "_IBX_" does not pass DD check" Q
127 S IBX=0 F S IBX=$O(IBMTDT21(IBX)) Q:'IBX D CHK^DIE(351.811,.02,,IBMTDT21(IBX),.IBQ) I IBQ="^" S HLERR="LTC Exempt date "_IBMTDT21(IBX)_" does not pass DD check" Q
128 ;
129 ; see if clock already exists or add
130 S IBX=$O(^IBA(351.81,"B",IB35181(.01),0))
131 I 'IBX S DIC="^IBA(351.81,",X=IB35181(.01),DIC(0)="",DIC("DR")=".02////^S X=DFN;4.01////"_$S($D(DUZ):DUZ,1:.5)_";4.02///NOW;4.03////"_$S($D(DUZ):DUZ,1:.5)_";4.04///NOW" K DO D FILE^DICN S IBX=+Y
132 I DFN'=$P($G(^IBA(351.81,IBX,0)),"^",2) S HLERR="Patient does not match LTC clock file entry" Q
133 ;
134 ; file top level file data received
135 S DIE="^IBA(351.81,",DA=IBX,DR="4.03////"_$S($D(DUZ):DUZ,1:.5)_";4.04///NOW" F X=.03,.04,.05 S DR=DR_";"_X_"////"_+IB35181(X)
136 D ^DIE
137 ;
138 ; clean out 21 days and re-file based on data received
139 S DIK="^IBA(351.81,"_IBX_",1,",DA(1)=IBX,IBY=0 F S IBY=$O(^IBA(351.81,IBX,1,IBY)) Q:'IBY S DA=IBY D ^DIK
140 S DIC=DIK,DIC(0)="",IBY=0 F S IBY=$O(IBMTDT21(IBY)) Q:'IBY S X=IBY,DIC("DR")=".02////^S X=IBMTDT21(IBY)" K DO D FILE^DICN
141 S IBLTCX=IBX D REINDEX^IBAECC
142 ;
143 Q
144 ;
145350 ; files data in 350 (ML type)
146 N IBQ,IBX,DIC,DIE,DR,X,Y,IBY,DA,DO,IBDESC
147 ;
148 ; do i have data
149 S IBQ=0 F IBX="TYP","IO","BS","EDT",.06,.07,.17,.14,.15,.05,"IDX" I $G(IB350(IBX))="" S IBQ=1 Q
150 I IBQ S HLERR="350 field "_IBX_" missing" Q
151 I $G(IB35471(.01))="" S HLERR="350 field .01 mssing" Q
152 ;
153 ;determine action type
154 S IB350(.03)=$$ATYPE(IB350("TYP"),IB350("IO"),IB350("BS")) I IB350(.03)=-1 S HLERR="Unable to determine Action Type" Q
155 S IB350(.03)=$O(^IBE(350.1,"B",IB350(.03),0)) I 'IB350(.03) S HLERR="Action Type not found in 350.1" Q
156 ;
157 ;determine brief description if any
158 I $D(^IBE(350.1,IB350(.03),20)) X ^(20)
159 ;
160 ;determine institution (defualt to here if not known)
161 S IB350(.13)=$S($D(IBINST):$$LKUP^XUAF4(IBINST),1:+$$SITE^VASITE)
162 ;
163 ;determine clinic stop if needed
164 I IB350("IO")="O" S IB350(.2)=$$GET3525^IBEMTSCU($E($G(IB350(.2)),1,3),$E($G(IB350(.2)),4,6),IB350(.17)) I 'IB350(.2) S HLERR="Unable to find valid clinic stop code in 352.5" Q
165 ;
166 ;check out data
167 S IB350(.01)=IB35471(.01)
168 F IBX=.01,.06,.07,.17,.14,.15,.05 D CHK^DIE(350,IBX,,IB350(IBX),.IBQ) I IBQ="^" S HLERR="File 350, field "_IBX_" does not pass DD check" Q
169 I $L($G(HLERR)) Q
170 S IB350(.22)=$O(^IBBAA(375,"C",IB350("IDX"),0)) I 'IB350(.22) S HLERR="PFSS Account Number not found" Q
171 ;
172 ;see if already exists or add
173 S IBX=$O(^IB("B",IB350(.01),0))
174 I 'IBX S DIC="^IB(",X=IB350(.01),DIC(0)="",DIC("DR")=".02////^S X=DFN;11////"_$S($D(DUZ):DUZ,1:.5)_";12///NOW;13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW" K DO D FILE^DICN S IBX=+Y
175 I DFN'=$P($G(^IB(IBX,0)),"^",2) S HLERR="Patient does not match IB file entry" Q
176 ;
177 ;file data
178 S DIE="^IB(",DA=IBX,DR=".05///^S X=IB350(.05);13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"_$S(IB350("IO")="O":";.2////^S X=IB350(.2)",1:"")_$S($D(IBDESC):";.08////^S X=IBDESC",1:"")
179 F IBY=.03,.06,.07,.13,.17,.14,.15,.22 S:'$L($P(^IB(IBX,0),"^",IBY*100)) DR=DR_";"_IBY_"////"_(+IB350(IBY))
180 D ^DIE
181 ;
182 Q
183 ;
184ERR ; trans type not found, set error
185 S HLERR="Transaction Type field not valid (.6)."
186 Q
187 ;
188ATYPE(IBTYP,IBIO,IBBS) ; used to determine action type
189 I IBTYP="MT",IBIO="O" Q "DG OPT COPAY NEW"
190 I IBTYP="MT",IBIO="I" Q "DG INPT COPAY ("_IBBS_") NEW"
191 I IBTYP="GMT",IBIO="I" Q "DG INPT COPAY ("_IBBS_") NEW"
192 I IBTYP="LTC",IBIO="O" Q "DG LTC OPT "_IBBS_" NEW"
193 I IBTYP="LTC",IBIO="I" Q "DG LTC INPT "_IBBS_" NEW"
194 I IBTYP="FEE",IBIO="O" Q "DG FEE SERVICE (OPT) NEW"
195 I IBTYP="FEE",IBIO="I" Q "DG FEE SERVICE (INPT) NEW"
196 I IBTYP="LTC FEE",IBIO="O" Q "DG LTC FEE OPT "_IBBS_" NEW"
197 I IBTYP="LTC FEE",IBIO="I" Q "DG LTC FEE INPT "_IBBS_" NEW"
198 I IBTYP="MT PERDIEM" Q "DG INPT PER DIEM NEW"
199 I IBTYP="MT",IBBS="OBS" Q "DG OBSERVATION COPAY NEW"
200 I IBTYP="CHAMPUS",IBIO="O" Q "DG TRICARE OPT COPAY NEW"
201 I IBTYP="CHAMPUS",IBIO="I" Q "DG TRICARE INPT COPAY NEW"
202 Q -1
203 ;
Note: See TracBrowser for help on using the repository browser.