ABSPOSBB ; IHS/FCS/DRS - POS billing - new ; [ 03/14/2003 11:18 AM ]
;;1.0;PHARMACY POINT OF SALE;**6,7,11,14,19,22,28,31,36,37,38,39,46,48**;JUN 21, 2001;Build 38
;
; When a transaction completes, POSTING^ABSPOSBB is called
; (the transaction completion happens in ^ABSPOSU)
; [Indirectly - via background job (ABSPOSBD).
; Transaction completion merely sets flag (ABSPOSBC)]
;
; You get ABSP57, pointer into ^ABSPTL(ABSP57,
; from whence comes all the transaction details.
;
; Your posting routine is called by $$.
; The result is stuffed into Field .15, POSTED TO A/R.
; It's a free text field. Use it in any way your interface desires.
;
; /IHS/OIT/RAM ; PATCH 48 ; Change: added for HEAT ticket # 135473; CR 07534 - pass insurer information to 3PB.
;
;
Q
POSTING ; EP - for _all_ billing interfaces - with ABSP57
; Based on the billing interface, call the right routine.
N X S X=$$ARSYSTEM^ABSPOSB
N RESULT
I X=0 D
. S RESULT=$$POST^ABSPOSBW ; FSI/ILC A/R Versions 1 and 2
E I X=1 D
. S RESULT="" ; none
E I X=2 D
. S RESULT=$$POST^ABSPOSBT ; ANMC nightly checker
E I X=3 D
. S RESULT=$$THIRD ; IHS Third Party Billing
E I X=4 D
. S RESULT=$$POST^ABSPOSBP ; PAC Patient Accounts Component (BBM*)
E I X=99 D
. S RESULT=$$POST^ABSPOSBQ ; other A/R (needs to fill in ABSPOSBQ)
E D
. S RESULT=""
. ; not a supported billing system interface
; Flag the 9002313.57 entry as having been processed by billing.
I RESULT]"" D
. N FDA,IEN,MSG
. S FDA(9002313.57,ABSP57_",",.15)=RESULT
. D FILE^DIE(,"FDA","MSG")
. I $D(MSG) D LOG^ABSPOSL2("F^ABSPOSBX",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q
; *********************************************************************
THIRD() ; IHS Third Party Billing ; ABSP*1.0T7*6 entire paragraph is new
N TX
S TX=ABSP57
N INSDFN,AMT,PATDFN,RXI,PRV,VDATE,CLINIC,LOC,ACCT,DISP,UNIT,QTY
N DRUG,NDC,RXR,CAT,INSNAM,VSTDFN,DA
N VMEDDFN
N ABSPOST ;IHS/OIT/SCR 011210 patch 36
N ABSPQUIT,ABSPRJCT ;IHS/OIT/SCR 020110 patch 37
N ABSPARAM ;IHS/OIT/CNI/SCR 052610 patch 39 - PARAMETER added to keep rejects from going to 3PB
S ABSPARAM=$$GET1^DIQ(9002313.99,1,170.02,"I") ;
S VSTDFN=$P($G(^ABSPTL(TX,0)),U,7) ; IEN to Visit file
Q:'VSTDFN "" ; No visit on this transaction
S RXR=$$GET1^DIQ(9002313.57,TX,9,"I") ; IEN refill Mult of RX file
S RXI=$$GET1^DIQ(9002313.57,TX,1.11,"I") ; IEN Prescription (RX) file
S INSDFN=$$GET1^DIQ(9002313.57,TX,1.06,"I") ; IEN to Insurer file
I 'INSDFN QUIT "" ; No ins on this transaction
;Get VMEDDFN
I RXR D
. S VMEDDFN=$P($G(^PSRX(RXI,1,RXR,999999911)),U) ;refill
E D
. S VMEDDFN=$P($G(^PSRX(RXI,999999911)),U) ;first fill
; CAT Should get value of E PAYABLE, E CAPTURED, E REJECTED
; Non-electronic ones will usually return as PAPER
S CAT=$$CATEG^ABSPOSUC(TX,1) ; Transaction category
; Posting of paper claims, next couple of lines
; Special only for assistance in setting up Training curriculum
; though it could be turned on for any site which so wishes.
; The "-22" in the next line is a memorial to
; the Great File Number Fiasco of Two Thousand Aught One
; I paper claims and posting of paper claims allowed, G POSTIT,
; else quit
;I CAT="PAPER" G POSTIT:$$GET1^DIQ(9002335.99-22,"1,",235.04,"I") Q ""
I CAT="PAPER" D POSTIT:$$GET1^DIQ(9002335.99-22,"1,",235.04,"I") Q ""
; I paper claims and posting of paper claims allowed, D REVERSIT
I CAT="PAPER REVERSAL" D Q DA
. S DA=""
. I $$GET1^DIQ(9002313.99,"1,",235.04,"I") D REVERSIT
I CAT'?1"E ".E Q "" ; Not electronic claims
;I CAT["REJECTED" Q "" ; Rejected claim
;IHS/OIT/SCR 020110 patch 37 START send additional REJECTED information to 3PB
;I CAT["REJECTED" D Q ""
S ABSPQUIT=0
I CAT["REJECTED" D
. ;I CAT="E REJECTED" D VMEDSTAT(VMEDDFN,2) ; 2 = POS Rejected
. D VMEDSTAT(VMEDDFN,2) ; 2 = POS Rejected
. I ABSPARAM'="Y" S ABSPQUIT=1 Q ;IHS/OIT/CNI/SCR patch 39 if the paramater is not 'Y' DON'T SEND
. S ABSPQUIT=1 Q ;IHS/OIT/CNI/SCR 072310 patch 39 don't send ANY reject info to 3PB until ok'd by federal lead - THEN remove this line
. I ABSPARAM="Y" D
. .N ABSPRSP,ABSPPOS,ABSPREJS,ABSPCNT
. .S ABSPRSP=$P($G(^ABSPTL(TX,0)),U,5)
. .S ABSPPOS=$P($G(^ABSPTL(TX,0)),U,9)
. .D REJTEXT^ABSPOS03(ABSPRSP,ABSPPOS,.ABSPREJS)
. .;This populates ABSPREJS(n) with code:text format of each rejection for this position in this response
. .S ABSPRJCT("RJCTIME")=$P($G(^ABSPR(ABSPRSP,0)),"^",2)
. .S ABSPCNT=0
. .F S ABSPCNT=$O(ABSPREJS(ABSPCNT)) Q:(ABSPCNT=""!ABSPQUIT) D
. . .S ABSPRJCT(ABSPCNT,"CODE")=$P(ABSPREJS(ABSPCNT),":",1)
. . .I ABSPRJCT(ABSPCNT,"CODE")="85" S ABSPQUIT=1 ;85 Claim Not Processed
. . .I ABSPRJCT(ABSPCNT,"CODE")="95" S ABSPQUIT=1 ;95 Time Out
. . .I ABSPRJCT(ABSPCNT,"CODE")="96" S ABSPQUIT=1 ;96 Scheduled Downtime
. . .I ABSPRJCT(ABSPCNT,"CODE")="97" S ABSPQUIT=1 ;97 Payer Unavailable
. . .I ABSPRJCT(ABSPCNT,"CODE")="98" S ABSPQUIT=1 ;98 Connection to Payer is Down
. . .I ABSPRJCT(ABSPCNT,"CODE")="R8" S ABSPQUIT=1 ;R8 Syntax Error
. . .S ABSPRJCT(ABSPCNT,"REASON")=$P(ABSPREJS(ABSPCNT),":",2)
;IHS/OIT/RCS 7/5/2013 Patch 46 - The Category 'E OTHER' should not be sent
I CAT="E OTHER" S ABSPQUIT=1 ;Considered an error
Q:ABSPQUIT 0 ;DON'T SEND UN-PROCESSED REJECTIONS TO 3PB - return used update free-text .14 field in ABSPT
;IHS/OIT/SCR 020110 patch 37 END send additional REJECTED information to 3PB
I CAT["DUPLICATE" D Q:'$$TIMEOUT ""
. I CAT="E DUPLICATE" D VMEDSTAT(VMEDDFN,1) ; 1 = POS Billed
I CAT["REVERSAL ACCEPTED" D REVERSIT Q DA ; Post reversal to A/R
I CAT="E CAPTURED" D VMEDSTAT(VMEDDFN,2) ; 2 = POS Rejected
I CAT="E PAYABLE" D VMEDSTAT(VMEDDFN,1) ; 1 = POS Billed
;IHS/OIT/SCR 011210 patch 36 start changes ; Create 3PB Bill
S ABSPOST=$$POSTIT(.ABSPRJCT)
Q ABSPOST
;IHS/OIT/SCR 011210 patch 36 end changes
REVERSIT ; sets DA on its way out ; ABSP*1.0T7*6 ; entire paragraph is new
N PRVTX,DIE,DR
S PRVTX=$$PREVIOUS(TX) ; Prev trans for RX & refill
I 'PRVTX S DA="" Q ; No previous transaction
S DA=$P($G(^ABSPTL(PRVTX,0)),U,15) ; A/R bill [DUZ(2),IEN]
Q:'DA ; A/R bill not specified
S RXI=$P(^ABSPTL(PRVTX,1),U,11) ; IEN to Prescripton file
S ABSPRX=$$GET1^DIQ(52,RXI,.01) ; RX #
Q:'ABSPRX ; No RX
; if posted ABSPWOFF will be DUZ(2),IEN (DA) of A/R bill; else null
S ABSP("CREDIT")=$$GET1^DIQ(9002313.57,PRVTX,505) ; $$ to reverse
S ABSP("ARLOC")=DA ; A/R Bill location
S ABSP("TRAN TYPE")=43 ; Adjustment
S ABSP("ADJ CAT")=3 ; Write off
S ABSP("ADJ TYPE")=135 ; Billed in error
S ABSP("USER")=$$GET1^DIQ(9002313.57,PRVTX,13) ; User who entered tran
N LOC,VISDT
S LOC=$$GET1^DIQ(9000010,VSTDFN,.06,"I") ; Location of Encounter
S VISDT=$P($P(^AUPNVSIT(VSTDFN,0),U,1),".",1) ; Visit Date
D LOG^ABSPOSL("Reversing transaction "_ABSP57_".")
;RLT - 11/20/07 - Patch 23 - remove call to A/R
;S ABSPWOFF=$$EN^BARPSAPI(.ABSP) ; Call published A/R API
;S ABSCAN=$$CAN^ABMPSAPI(ABSPWOFF) ; Cancel bill in 3PB ABSP*1.0T7*11
;IHS/OIT/SCR 4/17/08 Patch 31 START changes to pass RXREASON for cancellation
N ABSPRXRN
S ABSPRXRN=$$GET1^DIQ(9002313.57,TX,404) ; RXREASON in ABSP LOG OF TRANSACTION file
;S ABSCAN=$$CAN^ABMPSAPI(ABSP("ARLOC")) ;commented out and replaced by line below
;Cancel bill in 3PB - ABSP*1.0T7*11
S ABSCAN=$$CAN^ABMPSAPI(ABSP("ARLOC"),ABSPRXRN)
;Cancel bill in 3PB and pass 'reason' from Pharmacy 7.0
;IHS/OIT/SCR 4/17/08 Patch 31 END changes
D SETFLAG^ABSPOSBC(ABSP57,0) ; clear the "needs billing" flag
;S DA=ABSPWOFF
S DA=ABSP("ARLOC")
Q
POSTIT(ABSPRJCT) ; ABSP*1.0T7*6 ; entire paragraph is new
N ABSPOST ;IHS/OIT/SCR 011210 patch 36
N ABSPCNT ;IHS/OIT/SCR 020210 patch 37
N ABSPINS ;/IHS/OIT/RAM 18 MAY 2017; Patch 48, CR 07534
S ABSP(.21)=$$GET1^DIQ(9002313.57,TX,505) ; Total price
S ABSP(.23)=ABSP(.21)
S ABSP(.05)=$$GET1^DIQ(9002313.57,TX,5,"I") ; IEN to Patient file
S ABSP(.71)=$P($P(^AUPNVSIT(VSTDFN,0),U,1),".",1) ; Visit Date
S ABSP(.72)=ABSP(.71)
S ABSP(.1)=$$GET1^DIQ(9000010,VSTDFN,.08,"I") ; IEN to Clinic Stop
S ABSP(.03)=$$GET1^DIQ(9000010,VSTDFN,.06,"I") ; Location of Encounter
I ABSP(.03)="" D Q "" ;IHS/OIT/SCR 122809 patch 36 - if no location of Encounter, don't pass to 3PB
. D SETFLAG^ABSPOSBC(ABSP57,0) ; clear the "needs billing" flag'
. Q
S ABSP(.08)=INSDFN
S ABSP(.58)=$$GET1^DIQ(9002313.57,TX,1.09) ; Prior Authorization
S ABSP(.14)=$$GET1^DIQ(9002313.57,TX,13,"I") ; User
S ABSP(11,.01)=VSTDFN ; VISIT IEN IHS/OIT/SCR 020210 send patch 37
S ABSP(41,.01)=$S(RXI:$$GET1^DIQ(52,RXI,4,"I"),1:"") ; Provider
S ABSP(23,.01)=$$GET1^DIQ(9002313.57,TX,"1.11:DRUG","I") ; IEN to Drug File
S ABSP(23,.03)=$$GET1^DIQ(9002313.57,TX,501) ; Quantity
S ABSP(23,.04)=$$GET1^DIQ(9002313.57,TX,502) ; Unit Price
S ABSP(23,.05)=$$GET1^DIQ(9002313.57,TX,504) ; Dispensing Fee
S ABSP(23,.07)=$$GET1^DIQ(9002313.57,TX,507) ; Incentive Amount
S ABSP(23,19)=$$GET1^DIQ(9002313.57,TX,10403) ; New/Refill code
S RXI=$$GET1^DIQ(9002313.57,TX,1.11,"I")
S ABSP(23,.06)=$$GET1^DIQ(52,RXI,.01) ; Prescription
S ABSP(23,14)=$$GET1^DIQ(9002313.57,TX,10401) ; Date filled
S ABSP(23,20)=$$GET1^DIQ(9002313.57,TX,10405) ; Days supply
; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - Pass Insurer Information to 3PB. All code that follows until end comment is new for Patch 48.
S ABSPINS=$$GETINSINFO(TX) ; Gather all available insurance information for xfer to 3PB.
; As they say... plan for the worst, hope for the best. Just in case more info needs to be returned than the PRVT multiple, uncomment any needed info from the possibilities below.
; I +$P(ABSPINS,U,1)>0 S ABSP(13,.01)=$P(ABSPINS,U,1) ; Insurer pointer from the 701/702/703 field of ^ABSPTL.
; I +$P(ABSPINS,U,4)>0 S ABSP(13,.04)=$P(ABSPINS,U,4) ; Medicare multiple from the 601/602/603 field of ^ABSPTL.
; I +$P(ABSPINS,U,5)>0 S ABSP(13,.05)=$P(ABSPINS,U,5) ; Railroad multiple from the 601/602/603 field of ^ABSPTL.
; I +$P(ABSPINS,U,6)>0 S ABSP(13,.06)=$P(ABSPINS,U,6) ; Medicaid Eligible pointer from the 601/602/603 field of ^ABSPTL.
; I +$P(ABSPINS,U,7)>0 S ABSP(13,.07)=$P(ABSPINS,U,7) ; Medicaid multiple from the 601/602/603 field of ^ABSPTL.
I +$P(ABSPINS,U,8)>0 S ABSP(13,.08)=$P(ABSPINS,U,8) ; Private Insurance multiple from the 601/602/603 field of ^ABSPTL.
; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - End of new code detailed above.
;IHS/OIT/SCR 020210 patch 37 send reject information
I $G(ABSPRJCT("RJCTIME")) D
.S ABSPCNT=0
.S ABSP(73,"REJDATE")=$G(ABSPRJCT("RJCTIME"))
.F S ABSPCNT=$O(ABSPRJCT(ABSPCNT)) Q:ABSPCNT="RJCTIME" D
.. S ABSP(73,ABSPCNT,"CODE")=ABSPRJCT(ABSPCNT,"CODE")
.. S ABSP(73,ABSPCNT,"REASON")=ABSPRJCT(ABSPCNT,"REASON")
.. Q
.Q
;IHS/OIT/CNI/SCR patch 39 072310 START next four lines support for COB payer indicator field
N ABSP59,ABSPPTYP
S ABSP59=$$GET1^DIQ(9002313.57,TX,.01)
S ABSPPTYP=$E($P(ABSP59,".",2),1,1)
S ABSP(99,0)=$S(ABSPPTYP=2:"S",ABSPPTYP=3:"T",1:"") ; COB payer indicator - NULL for primary, S for secondary, T for tertiary
;IHS/SD/lwj 08/31/05 patch 14 nxt ln remkd out, following 3 added
;S ABSP("OTHIDENT")="0"_RXI ;can't assume we need to add a 0
S ABSP("OTHIDENT")=RXI
S:$L(RXI)>7 ABSP("OTHIDENT")=$E(RXI,$L(RXI)-6,$L(RXI))
S ABSP("OTHIDENT")=$$NFF^ABSPECFM($G(ABSP("OTHIDENT")),7)
;IHS/SD/lwj 08/31/05 end changes
D LOG^ABSPOSL("Posting transaction "_ABSP57_".")
S ABSPOST=$$EN^ABMPSAPI(.ABSP) ; Call published 3PB API
D SETFLAG^ABSPOSBC(ABSP57,0) ; clear the "needs billing" flag
S DA=ABSPOST
UPDT ;
Q DA
ZW(%) D ZW^ABSPOSB(%)
Q
PREVIOUS(N57) ;EP -
; Get Previous transaction for this RX and Refill
; N57 = TX = IEN to Log of Transactions file (A/R Posting)
N RXI,RXR
S RXI=$P(^ABSPTL(N57,1),U,11) ; IEN to Prescripton file
S RXR=$P(^ABSPTL(N57,1),U) ; IEN Refill mult of RX file
I RXI=""!(RXR="") Q "" ; if either value is blank Q
Q $O(^ABSPTL("NON-FILEMAN","RXIRXR",RXI,RXR,N57),-1)
LAST57(RXI,RXR) ;EP -
Q $O(^ABSPTL("NON-FILEMAN","RXIRXR",RXI,RXR,""),-1)
TIMEOUT() ;IHS/SD/lwj 3/14/03 Timed out payable claims?
; Following the conversion to 5.1, EDS/OK Medicaid had problems
; with their connection timing out with WebMD. EDS/OK Medicaid
; would process the claim, BUT, POS would get the time out
; response from WebMD (EV-16). When the claim is resubmitted in
; POS, if it was payable, OK Medicaid would respond with duplicate.
; Duplicates don't normally pass to 3rd party/ A/R, so we had to
; add extra code to look for this unique condition.
;
; Here's what we check when the response is duplicate:
; * We check to make sure the previous claim did not post to A/R
; * We check to make sure the previous claim was not reversed
; * We make sure the previous claim timed out with a EV-16
; * We check the version for 5.1
; * IHS/SD/lwj 7/7/04 patch 11 we now check for processor timeout
; If all this checks out, we want to post it to 3rd Party and A/R
N ABSPENT,ABSPREC,ABSPRC,ABSPRP,ABSPMSG
N PRCTO ;IHS/SD/lwj 7/7/04 patch 11 processor timeout
S ABSPENT=$P($G(^ABSPTL(TX,0)),U) ;entry # to use in b x-ref
S ABSPREC=$O(^ABSPTL("B",ABSPENT,TX),-1) ;get the previous trans
;IHS/SD/lwj 09/29/03 patch 7 line added below
Q:ABSPREC="" "" ;we don't have record of the dup claim - quit
Q:$P($G(^ABSPTL(ABSPREC,0)),U,15)'="" "" ;already posted
Q:$P($G(^ABSPTL(ABSPREC,4)),U)'="" "" ;prev one reversed
S ABSPRC=$P($G(^ABSPTL(TX,0)),U,5) ;current trans
Q:$P($G(^ABSPR(ABSPRC,100)),U,2)'[5 "" ;not a 5.1 trans
S ABSPRP=$P($G(^ABSPTL(ABSPREC,0)),U,5) ;prev response
;IHS/SD/lwj 09/29/03 patch 7 line added below
Q:ABSPRP="" "" ;no prev response - quit
Q:$P($G(^ABSPR(ABSPRP,100)),U,2)'[5 "" ;not a 5.1 trans
S ABSPMSG=$P($G(^ABSPR(ABSPRP,504)),U) ;message
;IHS/SD/lwj 7/7/04 next 2 lines added for patch 11
S PRCTO=0
S PRCTO=$$PROCTMOT(ABSPRP,ABSPREC) ;processor time out?
;IHS/SD/lwj 7/7/04 patch 11 nxt ln rmkd out, following added
;Q:$G(ABSPMSG)'["EV16" "" ;not a time out
Q:(($G(ABSPMSG)'["EV16")&('PRCTO)) "" ;not a time out
; from this point, looks like a time out that needs posting
Q 1
PROCTMOT(ABSPRP,ABSPREC) ;IHS/SD/lwj 7/7/04 need to check to see if the
; processor timed out - this is a different response from
; the switch time out
; ABSPPIC - rx order within response
; ABSPRXR - rej codes per rx
; ABSPTIMO - time out ind for resp
; ABSPRP - prev resp IEN (passed in)
; ABSPREC - prev log of tran IEN
N ABSPTIMO,ABSPRXR,ABSPPIC
Q:(ABSPRP="")!(ABSPREC="") ;must have to process
S (ABSPTIMO,ABSPRXR)=0 ;assume no tm out/init loop to 0
S ABSPPIC=$$GET1^DIQ(9002313.57,ABSPREC,14,"I") ;pos in prv clm/resp
I ABSPPIC="" Q ABSPTIMO ;IHS/OIT/SCR 05/07/09 avoid undefined error
F S ABSPRXR=$O(^ABSPR(ABSPRP,1000,ABSPPIC,511,ABSPRXR)) Q:'+ABSPRXR D
. S:$P($G(^ABSPR(ABSPRP,1000,ABSPPIC,511,ABSPRXR,0)),U)=95 ABSPTIMO=1
Q ABSPTIMO
VMEDSTAT(VMEDDFN,STAT) ;
;Populates POINT OF SALE BILLING STATUS (#1106) field in the
;V MEDICATION file (#9000010.14).
;NULL = NOT POS Billed
;1 = POS Billed
;2 = POS Rejected
Q:VMEDDFN="" ;quit if no pointer to the vmed file
Q:'$D(^DD(9000010.14,1106)) ;quit if no field 1106 in vmed file
S DIE=9000010.14,DA=VMEDDFN,DR="1106///^S X=STAT"
D ^DIE
Q
GETINSINFO(TX) ; /IHS/OIT/RAM ; 18 MAY 2017 - P48 - new routine to gather all the insurance information.
N BEG,END,I,I2,I3,ABSPPINNO,ABSPPINDATA,ABSPINSIEN,ABSPPINTYPE,ABSPELIGIEN,ABSPMULT,ABSPRETURN,ABSPTODAY ;/IHS/OIT/RAM 07534 Patch 48 - New parameters to hold temporary insurance info for 3PB.
S ABSPPINDATA="" ; verify that "no data" is empty on entry.
S ABSPRETURN="" ; verify that the return value is initialized -- return "nothing" if there is no data.
D NOW^%DTC S ABSPTODAY=X ; Get today's FileMan date -- useful if we have to manually find the correct Medicaid Multiple.
;
; Very little documentation on the PINS pieces; here's how (I think) they work:
; There are 5 types of PINS insurers: "CAID" (Medicaid),"PRVT"(Private Insurance),"CARE"(Medicare),"SELF PAY" & "RR"(rarely used.)
; The 2nd piece is the IEN in ^AUPNMCD, ^AUPNPRVT, ^AUPNMCR, [[ NO GLOBAL ]], & ^AUPNRRE (respective above).
; The 3rd piece is the "Multiple" - as each primary node can have multiple subnodes, this value is the correct subnode for the record.
; ** Warning! ** There is currently a bug in ABSP that does _not_ save the Medicaid multiple. The patch code below will need to account for that and manually generate the correct information.
; also, not sure if this is 'expected behaviour' but it seems that the 'active' insurance is always in PINS 1; but sometimes the PINS piece number will point to an empty 2/3/4. Possibly another bug.
S ABSPPINNO=$$GET1^DIQ(9002313.57,TX,1.08) ; PINS Piece Number ; determine which insurer (primary/secondary/tertiary) we're working with.
I ABSPPINNO=1 S ABSPPINDATA=$$GET1^DIQ(9002313.57,TX,601),ABSPINSIEN=$$GET1^DIQ(9002313.57,TX,701,"I") ; Pointer to #1 -- this will be the case most of the time.
I ABSPPINNO=2 S ABSPPINDATA=$$GET1^DIQ(9002313.57,TX,602),ABSPINSIEN=$$GET1^DIQ(9002313.57,TX,702,"I") ; Pointer to #2 -- this will probably be broken, but we need to take this into account.
I ABSPPINNO=3 S ABSPPINDATA=$$GET1^DIQ(9002313.57,TX,603),ABSPINSIEN=$$GET1^DIQ(9002313.57,TX,703,"I") ; Pointer to #3 -- this will probably be broken, but we need to take this into account.
; if 1>ABSPPINNO>3, leave ABSPPINDATA empty and don't add information to 3PB. may change if we need to add a 'broken' value to 3PB.
W "ABSPPINNO: ",ABSPPINNO," ABSPPINSIEN: ",ABSPINSIEN,!
I ABSPPINDATA'="" D ; Only add the data if there is actual ABSP PIN data available.
. I +ABSPINSIEN>0 S $P(ABSPRETURN,U,1)=ABSPINSIEN ; Return the current insurer IEN.
. S ABSPPINTYPE=$P(ABSPPINDATA,",",1) ; Separate the PIN type for further analysis.
. S ABSPELIGIEN=$P(ABSPPINDATA,",",2) ; Get the Eligibility IEN (not used for "SELF PAY", only passed with Medicaid.)
. S ABSPMULT=$P(ABSPPINDATA,",",3) ; And the multiple IEN - reminder: currently broken for Medicaid.
. I ABSPPINTYPE="RR" S $P(ABSPRETURN,U,5)=ABSPMULT
. I ABSPPINTYPE="CARE" S $P(ABSPRETURN,U,4)=ABSPMULT
. I ABSPPINTYPE="PRVT" S $P(ABSPRETURN,U,8)=ABSPMULT
. I ABSPPINTYPE="CAID" D
. . ; /IHS/OIT/RAM - Here's the "fun part" - we have to account for when the Medicaid pointer is fixed, and if not find the data manually.
. . I +ABSPELIGIEN>0 S $P(ABSPRETURN,U,6)=ABSPELIGIEN ; If the Eligability IEN exists, populate the .06 field.
. . I ABSPMULT?7N S $P(ABSPRETURN,U,7)=ABSPMULT ; If the Medicaid multiple is correct (a 7-digit FileMan date) populate the field.
. . E D ; If not... we have some work to do. Let's go find the correct multiple.
. . . S I="",GO=1 F S I=$O(^AUPNMCD(ABSPELIGIEN,11,I),-1) Q:I=""!('GO) D
. . . . S BEG=$P($G(^AUPNMCD(ABSPELIGIEN,11,I,0)),U,1),END=$P($G(^AUPNMCD(ABSPELIGIEN,11,I,0)),U,2)
. . . . W "ABSPTODAY: ",ABSPTODAY," TESTING: ",I," BEG: ",BEG," END: ",END,!
. . . . I (BEG<=ABSPTODAY)&(+END=0) W "FLERM.",! S GO=0,$P(ABSPRETURN,U,7)=I Q ; If "Today" is after the beginning date and there is no end date, this is an eligible multiple, store it and exit loop.
. . . . I (BEG<=ABSPTODAY)&(ABSPTODAY<END) S GO=0,$P(ABSPRETURN,U,7)=I Q ; If "Today" is between the eligible dates, this is an eligible multiple, store it and exit loop.
; That _should_ be all of the available data to send to 3PB; let's clean up the room and head back...
; RETURN DATA IS IN SAME FORM / ORDER AS THE 13 MULTIPLE NEEDS IN FILE 9002274.3:
; .01 / INSURER; .04 / MEDICARE MULTIPLE ; .05 / RAILROAD MULTIPLE ; .06 / MEDICAID ELIG POINTER
; .07 / MEDICAID MULTIPLE ; .08 / PRIVATE INSURANCE MULTIPLE
Q ABSPRETURN
; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - End of new code detailed above.
ABSPOSBB ; IHS/FCS/DRS - POS billing - new ; [ 03/14/2003 11:18 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**6,7,11,14,19,22,28,31,36,37,38,39,46,48**;JUN 21, 2001;Build 38
+2 ;
+3 ; When a transaction completes, POSTING^ABSPOSBB is called
+4 ; (the transaction completion happens in ^ABSPOSU)
+5 ; [Indirectly - via background job (ABSPOSBD).
+6 ; Transaction completion merely sets flag (ABSPOSBC)]
+7 ;
+8 ; You get ABSP57, pointer into ^ABSPTL(ABSP57,
+9 ; from whence comes all the transaction details.
+10 ;
+11 ; Your posting routine is called by $$.
+12 ; The result is stuffed into Field .15, POSTED TO A/R.
+13 ; It's a free text field. Use it in any way your interface desires.
+14 ;
+15 ; /IHS/OIT/RAM ; PATCH 48 ; Change: added for HEAT ticket # 135473; CR 07534 - pass insurer information to 3PB.
+16 ;
+17 ;
+18 QUIT
POSTING ; EP - for _all_ billing interfaces - with ABSP57
+1 ; Based on the billing interface, call the right routine.
+2 NEW X
SET X=$$ARSYSTEM^ABSPOSB
+3 NEW RESULT
+4 IF X=0
Begin DoDot:1
+5 ; FSI/ILC A/R Versions 1 and 2
SET RESULT=$$POST^ABSPOSBW
End DoDot:1
+6 IF '$TEST
IF X=1
Begin DoDot:1
+7 ; none
SET RESULT=""
End DoDot:1
+8 IF '$TEST
IF X=2
Begin DoDot:1
+9 ; ANMC nightly checker
SET RESULT=$$POST^ABSPOSBT
End DoDot:1
+10 IF '$TEST
IF X=3
Begin DoDot:1
+11 ; IHS Third Party Billing
SET RESULT=$$THIRD
End DoDot:1
+12 IF '$TEST
IF X=4
Begin DoDot:1
+13 ; PAC Patient Accounts Component (BBM*)
SET RESULT=$$POST^ABSPOSBP
End DoDot:1
+14 IF '$TEST
IF X=99
Begin DoDot:1
+15 ; other A/R (needs to fill in ABSPOSBQ)
SET RESULT=$$POST^ABSPOSBQ
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 SET RESULT=""
+18 ; not a supported billing system interface
End DoDot:1
+19 ; Flag the 9002313.57 entry as having been processed by billing.
+20 IF RESULT]""
Begin DoDot:1
+21 NEW FDA,IEN,MSG
+22 SET FDA(9002313.57,ABSP57_",",.15)=RESULT
+23 DO FILE^DIE(,"FDA","MSG")
+24 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("F^ABSPOSBX",.MSG)
End DoDot:1
+25 QUIT
+26 ; *********************************************************************
THIRD() ; IHS Third Party Billing ; ABSP*1.0T7*6 entire paragraph is new
+1 NEW TX
+2 SET TX=ABSP57
+3 NEW INSDFN,AMT,PATDFN,RXI,PRV,VDATE,CLINIC,LOC,ACCT,DISP,UNIT,QTY
+4 NEW DRUG,NDC,RXR,CAT,INSNAM,VSTDFN,DA
+5 NEW VMEDDFN
+6 ;IHS/OIT/SCR 011210 patch 36
NEW ABSPOST
+7 ;IHS/OIT/SCR 020110 patch 37
NEW ABSPQUIT,ABSPRJCT
+8 ;IHS/OIT/CNI/SCR 052610 patch 39 - PARAMETER added to keep rejects from going to 3PB
NEW ABSPARAM
+9 ;
SET ABSPARAM=$$GET1^DIQ(9002313.99,1,170.02,"I")
+10 ; IEN to Visit file
SET VSTDFN=$PIECE($GET(^ABSPTL(TX,0)),U,7)
+11 ; No visit on this transaction
IF 'VSTDFN
QUIT ""
+12 ; IEN refill Mult of RX file
SET RXR=$$GET1^DIQ(9002313.57,TX,9,"I")
+13 ; IEN Prescription (RX) file
SET RXI=$$GET1^DIQ(9002313.57,TX,1.11,"I")
+14 ; IEN to Insurer file
SET INSDFN=$$GET1^DIQ(9002313.57,TX,1.06,"I")
+15 ; No ins on this transaction
IF 'INSDFN
QUIT ""
+16 ;Get VMEDDFN
+17 IF RXR
Begin DoDot:1
+18 ;refill
SET VMEDDFN=$PIECE($GET(^PSRX(RXI,1,RXR,999999911)),U)
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 ;first fill
SET VMEDDFN=$PIECE($GET(^PSRX(RXI,999999911)),U)
End DoDot:1
+21 ; CAT Should get value of E PAYABLE, E CAPTURED, E REJECTED
+22 ; Non-electronic ones will usually return as PAPER
+23 ; Transaction category
SET CAT=$$CATEG^ABSPOSUC(TX,1)
+24 ; Posting of paper claims, next couple of lines
+25 ; Special only for assistance in setting up Training curriculum
+26 ; though it could be turned on for any site which so wishes.
+27 ; The "-22" in the next line is a memorial to
+28 ; the Great File Number Fiasco of Two Thousand Aught One
+29 ; I paper claims and posting of paper claims allowed, G POSTIT,
+30 ; else quit
+31 ;I CAT="PAPER" G POSTIT:$$GET1^DIQ(9002335.99-22,"1,",235.04,"I") Q ""
+32 IF CAT="PAPER"
IF $$GET1^DIQ(9002335.99-22,"1,",235.04,"I")
DO POSTIT
QUIT ""
+33 ; I paper claims and posting of paper claims allowed, D REVERSIT
+34 IF CAT="PAPER REVERSAL"
Begin DoDot:1
+35 SET DA=""
+36 IF $$GET1^DIQ(9002313.99,"1,",235.04,"I")
DO REVERSIT
End DoDot:1
QUIT DA
+37 ; Not electronic claims
IF CAT'?1"E ".E
QUIT ""
+38 ;I CAT["REJECTED" Q "" ; Rejected claim
+39 ;IHS/OIT/SCR 020110 patch 37 START send additional REJECTED information to 3PB
+40 ;I CAT["REJECTED" D Q ""
+41 SET ABSPQUIT=0
+42 IF CAT["REJECTED"
Begin DoDot:1
+43 ;I CAT="E REJECTED" D VMEDSTAT(VMEDDFN,2) ; 2 = POS Rejected
+44 ; 2 = POS Rejected
DO VMEDSTAT(VMEDDFN,2)
+45 ;IHS/OIT/CNI/SCR patch 39 if the paramater is not 'Y' DON'T SEND
IF ABSPARAM'="Y"
SET ABSPQUIT=1
QUIT
+46 ;IHS/OIT/CNI/SCR 072310 patch 39 don't send ANY reject info to 3PB until ok'd by federal lead - THEN remove this line
SET ABSPQUIT=1
QUIT
+47 IF ABSPARAM="Y"
Begin DoDot:2
+48 NEW ABSPRSP,ABSPPOS,ABSPREJS,ABSPCNT
+49 SET ABSPRSP=$PIECE($GET(^ABSPTL(TX,0)),U,5)
+50 SET ABSPPOS=$PIECE($GET(^ABSPTL(TX,0)),U,9)
+51 DO REJTEXT^ABSPOS03(ABSPRSP,ABSPPOS,.ABSPREJS)
+52 ;This populates ABSPREJS(n) with code:text format of each rejection for this position in this response
+53 SET ABSPRJCT("RJCTIME")=$PIECE($GET(^ABSPR(ABSPRSP,0)),"^",2)
+54 SET ABSPCNT=0
+55 FOR
SET ABSPCNT=$ORDER(ABSPREJS(ABSPCNT))
IF (ABSPCNT=""!ABSPQUIT)
QUIT
Begin DoDot:3
+56 SET ABSPRJCT(ABSPCNT,"CODE")=$PIECE(ABSPREJS(ABSPCNT),":",1)
+57 ;85 Claim Not Processed
IF ABSPRJCT(ABSPCNT,"CODE")="85"
SET ABSPQUIT=1
+58 ;95 Time Out
IF ABSPRJCT(ABSPCNT,"CODE")="95"
SET ABSPQUIT=1
+59 ;96 Scheduled Downtime
IF ABSPRJCT(ABSPCNT,"CODE")="96"
SET ABSPQUIT=1
+60 ;97 Payer Unavailable
IF ABSPRJCT(ABSPCNT,"CODE")="97"
SET ABSPQUIT=1
+61 ;98 Connection to Payer is Down
IF ABSPRJCT(ABSPCNT,"CODE")="98"
SET ABSPQUIT=1
+62 ;R8 Syntax Error
IF ABSPRJCT(ABSPCNT,"CODE")="R8"
SET ABSPQUIT=1
+63 SET ABSPRJCT(ABSPCNT,"REASON")=$PIECE(ABSPREJS(ABSPCNT),":",2)
End DoDot:3
End DoDot:2
End DoDot:1
+64 ;IHS/OIT/RCS 7/5/2013 Patch 46 - The Category 'E OTHER' should not be sent
+65 ;Considered an error
IF CAT="E OTHER"
SET ABSPQUIT=1
+66 ;DON'T SEND UN-PROCESSED REJECTIONS TO 3PB - return used update free-text .14 field in ABSPT
IF ABSPQUIT
QUIT 0
+67 ;IHS/OIT/SCR 020110 patch 37 END send additional REJECTED information to 3PB
+68 IF CAT["DUPLICATE"
Begin DoDot:1
+69 ; 1 = POS Billed
IF CAT="E DUPLICATE"
DO VMEDSTAT(VMEDDFN,1)
End DoDot:1
IF '$$TIMEOUT
QUIT ""
+70 ; Post reversal to A/R
IF CAT["REVERSAL ACCEPTED"
DO REVERSIT
QUIT DA
+71 ; 2 = POS Rejected
IF CAT="E CAPTURED"
DO VMEDSTAT(VMEDDFN,2)
+72 ; 1 = POS Billed
IF CAT="E PAYABLE"
DO VMEDSTAT(VMEDDFN,1)
+73 ;IHS/OIT/SCR 011210 patch 36 start changes ; Create 3PB Bill
+74 SET ABSPOST=$$POSTIT(.ABSPRJCT)
+75 QUIT ABSPOST
+76 ;IHS/OIT/SCR 011210 patch 36 end changes
REVERSIT ; sets DA on its way out ; ABSP*1.0T7*6 ; entire paragraph is new
+1 NEW PRVTX,DIE,DR
+2 ; Prev trans for RX & refill
SET PRVTX=$$PREVIOUS(TX)
+3 ; No previous transaction
IF 'PRVTX
SET DA=""
QUIT
+4 ; A/R bill [DUZ(2),IEN]
SET DA=$PIECE($GET(^ABSPTL(PRVTX,0)),U,15)
+5 ; A/R bill not specified
IF 'DA
QUIT
+6 ; IEN to Prescripton file
SET RXI=$PIECE(^ABSPTL(PRVTX,1),U,11)
+7 ; RX #
SET ABSPRX=$$GET1^DIQ(52,RXI,.01)
+8 ; No RX
IF 'ABSPRX
QUIT
+9 ; if posted ABSPWOFF will be DUZ(2),IEN (DA) of A/R bill; else null
+10 ; $$ to reverse
SET ABSP("CREDIT")=$$GET1^DIQ(9002313.57,PRVTX,505)
+11 ; A/R Bill location
SET ABSP("ARLOC")=DA
+12 ; Adjustment
SET ABSP("TRAN TYPE")=43
+13 ; Write off
SET ABSP("ADJ CAT")=3
+14 ; Billed in error
SET ABSP("ADJ TYPE")=135
+15 ; User who entered tran
SET ABSP("USER")=$$GET1^DIQ(9002313.57,PRVTX,13)
+16 NEW LOC,VISDT
+17 ; Location of Encounter
SET LOC=$$GET1^DIQ(9000010,VSTDFN,.06,"I")
+18 ; Visit Date
SET VISDT=$PIECE($PIECE(^AUPNVSIT(VSTDFN,0),U,1),".",1)
+19 DO LOG^ABSPOSL("Reversing transaction "_ABSP57_".")
+20 ;RLT - 11/20/07 - Patch 23 - remove call to A/R
+21 ;S ABSPWOFF=$$EN^BARPSAPI(.ABSP) ; Call published A/R API
+22 ;S ABSCAN=$$CAN^ABMPSAPI(ABSPWOFF) ; Cancel bill in 3PB ABSP*1.0T7*11
+23 ;IHS/OIT/SCR 4/17/08 Patch 31 START changes to pass RXREASON for cancellation
+24 NEW ABSPRXRN
+25 ; RXREASON in ABSP LOG OF TRANSACTION file
SET ABSPRXRN=$$GET1^DIQ(9002313.57,TX,404)
+26 ;S ABSCAN=$$CAN^ABMPSAPI(ABSP("ARLOC")) ;commented out and replaced by line below
+27 ;Cancel bill in 3PB - ABSP*1.0T7*11
+28 SET ABSCAN=$$CAN^ABMPSAPI(ABSP("ARLOC"),ABSPRXRN)
+29 ;Cancel bill in 3PB and pass 'reason' from Pharmacy 7.0
+30 ;IHS/OIT/SCR 4/17/08 Patch 31 END changes
+31 ; clear the "needs billing" flag
DO SETFLAG^ABSPOSBC(ABSP57,0)
+32 ;S DA=ABSPWOFF
+33 SET DA=ABSP("ARLOC")
+34 QUIT
POSTIT(ABSPRJCT) ; ABSP*1.0T7*6 ; entire paragraph is new
+1 ;IHS/OIT/SCR 011210 patch 36
NEW ABSPOST
+2 ;IHS/OIT/SCR 020210 patch 37
NEW ABSPCNT
+3 ;/IHS/OIT/RAM 18 MAY 2017; Patch 48, CR 07534
NEW ABSPINS
+4 ; Total price
SET ABSP(.21)=$$GET1^DIQ(9002313.57,TX,505)
+5 SET ABSP(.23)=ABSP(.21)
+6 ; IEN to Patient file
SET ABSP(.05)=$$GET1^DIQ(9002313.57,TX,5,"I")
+7 ; Visit Date
SET ABSP(.71)=$PIECE($PIECE(^AUPNVSIT(VSTDFN,0),U,1),".",1)
+8 SET ABSP(.72)=ABSP(.71)
+9 ; IEN to Clinic Stop
SET ABSP(.1)=$$GET1^DIQ(9000010,VSTDFN,.08,"I")
+10 ; Location of Encounter
SET ABSP(.03)=$$GET1^DIQ(9000010,VSTDFN,.06,"I")
+11 ;IHS/OIT/SCR 122809 patch 36 - if no location of Encounter, don't pass to 3PB
IF ABSP(.03)=""
Begin DoDot:1
+12 ; clear the "needs billing" flag'
DO SETFLAG^ABSPOSBC(ABSP57,0)
+13 QUIT
End DoDot:1
QUIT ""
+14 SET ABSP(.08)=INSDFN
+15 ; Prior Authorization
SET ABSP(.58)=$$GET1^DIQ(9002313.57,TX,1.09)
+16 ; User
SET ABSP(.14)=$$GET1^DIQ(9002313.57,TX,13,"I")
+17 ; VISIT IEN IHS/OIT/SCR 020210 send patch 37
SET ABSP(11,.01)=VSTDFN
+18 ; Provider
SET ABSP(41,.01)=$SELECT(RXI:$$GET1^DIQ(52,RXI,4,"I"),1:"")
+19 ; IEN to Drug File
SET ABSP(23,.01)=$$GET1^DIQ(9002313.57,TX,"1.11:DRUG","I")
+20 ; Quantity
SET ABSP(23,.03)=$$GET1^DIQ(9002313.57,TX,501)
+21 ; Unit Price
SET ABSP(23,.04)=$$GET1^DIQ(9002313.57,TX,502)
+22 ; Dispensing Fee
SET ABSP(23,.05)=$$GET1^DIQ(9002313.57,TX,504)
+23 ; Incentive Amount
SET ABSP(23,.07)=$$GET1^DIQ(9002313.57,TX,507)
+24 ; New/Refill code
SET ABSP(23,19)=$$GET1^DIQ(9002313.57,TX,10403)
+25 SET RXI=$$GET1^DIQ(9002313.57,TX,1.11,"I")
+26 ; Prescription
SET ABSP(23,.06)=$$GET1^DIQ(52,RXI,.01)
+27 ; Date filled
SET ABSP(23,14)=$$GET1^DIQ(9002313.57,TX,10401)
+28 ; Days supply
SET ABSP(23,20)=$$GET1^DIQ(9002313.57,TX,10405)
+29 ; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - Pass Insurer Information to 3PB. All code that follows until end comment is new for Patch 48.
+30 ; Gather all available insurance information for xfer to 3PB.
SET ABSPINS=$$GETINSINFO(TX)
+31 ; As they say... plan for the worst, hope for the best. Just in case more info needs to be returned than the PRVT multiple, uncomment any needed info from the possibilities below.
+32 ; I +$P(ABSPINS,U,1)>0 S ABSP(13,.01)=$P(ABSPINS,U,1) ; Insurer pointer from the 701/702/703 field of ^ABSPTL.
+33 ; I +$P(ABSPINS,U,4)>0 S ABSP(13,.04)=$P(ABSPINS,U,4) ; Medicare multiple from the 601/602/603 field of ^ABSPTL.
+34 ; I +$P(ABSPINS,U,5)>0 S ABSP(13,.05)=$P(ABSPINS,U,5) ; Railroad multiple from the 601/602/603 field of ^ABSPTL.
+35 ; I +$P(ABSPINS,U,6)>0 S ABSP(13,.06)=$P(ABSPINS,U,6) ; Medicaid Eligible pointer from the 601/602/603 field of ^ABSPTL.
+36 ; I +$P(ABSPINS,U,7)>0 S ABSP(13,.07)=$P(ABSPINS,U,7) ; Medicaid multiple from the 601/602/603 field of ^ABSPTL.
+37 ; Private Insurance multiple from the 601/602/603 field of ^ABSPTL.
IF +$PIECE(ABSPINS,U,8)>0
SET ABSP(13,.08)=$PIECE(ABSPINS,U,8)
+38 ; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - End of new code detailed above.
+39 ;IHS/OIT/SCR 020210 patch 37 send reject information
+40 IF $GET(ABSPRJCT("RJCTIME"))
Begin DoDot:1
+41 SET ABSPCNT=0
+42 SET ABSP(73,"REJDATE")=$GET(ABSPRJCT("RJCTIME"))
+43 FOR
SET ABSPCNT=$ORDER(ABSPRJCT(ABSPCNT))
IF ABSPCNT="RJCTIME"
QUIT
Begin DoDot:2
+44 SET ABSP(73,ABSPCNT,"CODE")=ABSPRJCT(ABSPCNT,"CODE")
+45 SET ABSP(73,ABSPCNT,"REASON")=ABSPRJCT(ABSPCNT,"REASON")
+46 QUIT
End DoDot:2
+47 QUIT
End DoDot:1
+48 ;IHS/OIT/CNI/SCR patch 39 072310 START next four lines support for COB payer indicator field
+49 NEW ABSP59,ABSPPTYP
+50 SET ABSP59=$$GET1^DIQ(9002313.57,TX,.01)
+51 SET ABSPPTYP=$EXTRACT($PIECE(ABSP59,".",2),1,1)
+52 ; COB payer indicator - NULL for primary, S for secondary, T for tertiary
SET ABSP(99,0)=$SELECT(ABSPPTYP=2:"S",ABSPPTYP=3:"T",1:"")
+53 ;IHS/SD/lwj 08/31/05 patch 14 nxt ln remkd out, following 3 added
+54 ;S ABSP("OTHIDENT")="0"_RXI ;can't assume we need to add a 0
+55 SET ABSP("OTHIDENT")=RXI
+56 IF $LENGTH(RXI)>7
SET ABSP("OTHIDENT")=$EXTRACT(RXI,$LENGTH(RXI)-6,$LENGTH(RXI))
+57 SET ABSP("OTHIDENT")=$$NFF^ABSPECFM($GET(ABSP("OTHIDENT")),7)
+58 ;IHS/SD/lwj 08/31/05 end changes
+59 DO LOG^ABSPOSL("Posting transaction "_ABSP57_".")
+60 ; Call published 3PB API
SET ABSPOST=$$EN^ABMPSAPI(.ABSP)
+61 ; clear the "needs billing" flag
DO SETFLAG^ABSPOSBC(ABSP57,0)
+62 SET DA=ABSPOST
UPDT ;
+1 QUIT DA
ZW(%) DO ZW^ABSPOSB(%)
+1 QUIT
PREVIOUS(N57) ;EP -
+1 ; Get Previous transaction for this RX and Refill
+2 ; N57 = TX = IEN to Log of Transactions file (A/R Posting)
+3 NEW RXI,RXR
+4 ; IEN to Prescripton file
SET RXI=$PIECE(^ABSPTL(N57,1),U,11)
+5 ; IEN Refill mult of RX file
SET RXR=$PIECE(^ABSPTL(N57,1),U)
+6 ; if either value is blank Q
IF RXI=""!(RXR="")
QUIT ""
+7 QUIT $ORDER(^ABSPTL("NON-FILEMAN","RXIRXR",RXI,RXR,N57),-1)
LAST57(RXI,RXR) ;EP -
+1 QUIT $ORDER(^ABSPTL("NON-FILEMAN","RXIRXR",RXI,RXR,""),-1)
TIMEOUT() ;IHS/SD/lwj 3/14/03 Timed out payable claims?
+1 ; Following the conversion to 5.1, EDS/OK Medicaid had problems
+2 ; with their connection timing out with WebMD. EDS/OK Medicaid
+3 ; would process the claim, BUT, POS would get the time out
+4 ; response from WebMD (EV-16). When the claim is resubmitted in
+5 ; POS, if it was payable, OK Medicaid would respond with duplicate.
+6 ; Duplicates don't normally pass to 3rd party/ A/R, so we had to
+7 ; add extra code to look for this unique condition.
+8 ;
+9 ; Here's what we check when the response is duplicate:
+10 ; * We check to make sure the previous claim did not post to A/R
+11 ; * We check to make sure the previous claim was not reversed
+12 ; * We make sure the previous claim timed out with a EV-16
+13 ; * We check the version for 5.1
+14 ; * IHS/SD/lwj 7/7/04 patch 11 we now check for processor timeout
+15 ; If all this checks out, we want to post it to 3rd Party and A/R
+16 NEW ABSPENT,ABSPREC,ABSPRC,ABSPRP,ABSPMSG
+17 ;IHS/SD/lwj 7/7/04 patch 11 processor timeout
NEW PRCTO
+18 ;entry # to use in b x-ref
SET ABSPENT=$PIECE($GET(^ABSPTL(TX,0)),U)
+19 ;get the previous trans
SET ABSPREC=$ORDER(^ABSPTL("B",ABSPENT,TX),-1)
+20 ;IHS/SD/lwj 09/29/03 patch 7 line added below
+21 ;we don't have record of the dup claim - quit
IF ABSPREC=""
QUIT ""
+22 ;already posted
IF $PIECE($GET(^ABSPTL(ABSPREC,0)),U,15)'=""
QUIT ""
+23 ;prev one reversed
IF $PIECE($GET(^ABSPTL(ABSPREC,4)),U)'=""
QUIT ""
+24 ;current trans
SET ABSPRC=$PIECE($GET(^ABSPTL(TX,0)),U,5)
+25 ;not a 5.1 trans
IF $PIECE($GET(^ABSPR(ABSPRC,100)),U,2)'[5
QUIT ""
+26 ;prev response
SET ABSPRP=$PIECE($GET(^ABSPTL(ABSPREC,0)),U,5)
+27 ;IHS/SD/lwj 09/29/03 patch 7 line added below
+28 ;no prev response - quit
IF ABSPRP=""
QUIT ""
+29 ;not a 5.1 trans
IF $PIECE($GET(^ABSPR(ABSPRP,100)),U,2)'[5
QUIT ""
+30 ;message
SET ABSPMSG=$PIECE($GET(^ABSPR(ABSPRP,504)),U)
+31 ;IHS/SD/lwj 7/7/04 next 2 lines added for patch 11
+32 SET PRCTO=0
+33 ;processor time out?
SET PRCTO=$$PROCTMOT(ABSPRP,ABSPREC)
+34 ;IHS/SD/lwj 7/7/04 patch 11 nxt ln rmkd out, following added
+35 ;Q:$G(ABSPMSG)'["EV16" "" ;not a time out
+36 ;not a time out
IF (($GET(ABSPMSG)'["EV16")&('PRCTO))
QUIT ""
+37 ; from this point, looks like a time out that needs posting
+38 QUIT 1
PROCTMOT(ABSPRP,ABSPREC) ;IHS/SD/lwj 7/7/04 need to check to see if the
+1 ; processor timed out - this is a different response from
+2 ; the switch time out
+3 ; ABSPPIC - rx order within response
+4 ; ABSPRXR - rej codes per rx
+5 ; ABSPTIMO - time out ind for resp
+6 ; ABSPRP - prev resp IEN (passed in)
+7 ; ABSPREC - prev log of tran IEN
+8 NEW ABSPTIMO,ABSPRXR,ABSPPIC
+9 ;must have to process
IF (ABSPRP="")!(ABSPREC="")
QUIT
+10 ;assume no tm out/init loop to 0
SET (ABSPTIMO,ABSPRXR)=0
+11 ;pos in prv clm/resp
SET ABSPPIC=$$GET1^DIQ(9002313.57,ABSPREC,14,"I")
+12 ;IHS/OIT/SCR 05/07/09 avoid undefined error
IF ABSPPIC=""
QUIT ABSPTIMO
+13 FOR
SET ABSPRXR=$ORDER(^ABSPR(ABSPRP,1000,ABSPPIC,511,ABSPRXR))
IF '+ABSPRXR
QUIT
Begin DoDot:1
+14 IF $PIECE($GET(^ABSPR(ABSPRP,1000,ABSPPIC,511,ABSPRXR,0)),U)=95
SET ABSPTIMO=1
End DoDot:1
+15 QUIT ABSPTIMO
VMEDSTAT(VMEDDFN,STAT) ;
+1 ;Populates POINT OF SALE BILLING STATUS (#1106) field in the
+2 ;V MEDICATION file (#9000010.14).
+3 ;NULL = NOT POS Billed
+4 ;1 = POS Billed
+5 ;2 = POS Rejected
+6 ;quit if no pointer to the vmed file
IF VMEDDFN=""
QUIT
+7 ;quit if no field 1106 in vmed file
IF '$DATA(^DD(9000010.14,1106))
QUIT
+8 SET DIE=9000010.14
SET DA=VMEDDFN
SET DR="1106///^S X=STAT"
+9 DO ^DIE
+10 QUIT
GETINSINFO(TX) ; /IHS/OIT/RAM ; 18 MAY 2017 - P48 - new routine to gather all the insurance information.
+1 ;/IHS/OIT/RAM 07534 Patch 48 - New parameters to hold temporary insurance info for 3PB.
NEW BEG,END,I,I2,I3,ABSPPINNO,ABSPPINDATA,ABSPINSIEN,ABSPPINTYPE,ABSPELIGIEN,ABSPMULT,ABSPRETURN,ABSPTODAY
+2 ; verify that "no data" is empty on entry.
SET ABSPPINDATA=""
+3 ; verify that the return value is initialized -- return "nothing" if there is no data.
SET ABSPRETURN=""
+4 ; Get today's FileMan date -- useful if we have to manually find the correct Medicaid Multiple.
DO NOW^%DTC
SET ABSPTODAY=X
+5 ;
+6 ; Very little documentation on the PINS pieces; here's how (I think) they work:
+7 ; There are 5 types of PINS insurers: "CAID" (Medicaid),"PRVT"(Private Insurance),"CARE"(Medicare),"SELF PAY" & "RR"(rarely used.)
+8 ; The 2nd piece is the IEN in ^AUPNMCD, ^AUPNPRVT, ^AUPNMCR, [[ NO GLOBAL ]], & ^AUPNRRE (respective above).
+9 ; The 3rd piece is the "Multiple" - as each primary node can have multiple subnodes, this value is the correct subnode for the record.
+10 ; ** Warning! ** There is currently a bug in ABSP that does _not_ save the Medicaid multiple. The patch code below will need to account for that and manually generate the correct information.
+11 ; also, not sure if this is 'expected behaviour' but it seems that the 'active' insurance is always in PINS 1; but sometimes the PINS piece number will point to an empty 2/3/4. Possibly another bug.
+12 ; PINS Piece Number ; determine which insurer (primary/secondary/tertiary) we're working with.
SET ABSPPINNO=$$GET1^DIQ(9002313.57,TX,1.08)
+13 ; Pointer to #1 -- this will be the case most of the time.
IF ABSPPINNO=1
SET ABSPPINDATA=$$GET1^DIQ(9002313.57,TX,601)
SET ABSPINSIEN=$$GET1^DIQ(9002313.57,TX,701,"I")
+14 ; Pointer to #2 -- this will probably be broken, but we need to take this into account.
IF ABSPPINNO=2
SET ABSPPINDATA=$$GET1^DIQ(9002313.57,TX,602)
SET ABSPINSIEN=$$GET1^DIQ(9002313.57,TX,702,"I")
+15 ; Pointer to #3 -- this will probably be broken, but we need to take this into account.
IF ABSPPINNO=3
SET ABSPPINDATA=$$GET1^DIQ(9002313.57,TX,603)
SET ABSPINSIEN=$$GET1^DIQ(9002313.57,TX,703,"I")
+16 ; if 1>ABSPPINNO>3, leave ABSPPINDATA empty and don't add information to 3PB. may change if we need to add a 'broken' value to 3PB.
+17 WRITE "ABSPPINNO: ",ABSPPINNO," ABSPPINSIEN: ",ABSPINSIEN,!
+18 ; Only add the data if there is actual ABSP PIN data available.
IF ABSPPINDATA'=""
Begin DoDot:1
+19 ; Return the current insurer IEN.
IF +ABSPINSIEN>0
SET $PIECE(ABSPRETURN,U,1)=ABSPINSIEN
+20 ; Separate the PIN type for further analysis.
SET ABSPPINTYPE=$PIECE(ABSPPINDATA,",",1)
+21 ; Get the Eligibility IEN (not used for "SELF PAY", only passed with Medicaid.)
SET ABSPELIGIEN=$PIECE(ABSPPINDATA,",",2)
+22 ; And the multiple IEN - reminder: currently broken for Medicaid.
SET ABSPMULT=$PIECE(ABSPPINDATA,",",3)
+23 IF ABSPPINTYPE="RR"
SET $PIECE(ABSPRETURN,U,5)=ABSPMULT
+24 IF ABSPPINTYPE="CARE"
SET $PIECE(ABSPRETURN,U,4)=ABSPMULT
+25 IF ABSPPINTYPE="PRVT"
SET $PIECE(ABSPRETURN,U,8)=ABSPMULT
+26 IF ABSPPINTYPE="CAID"
Begin DoDot:2
+27 ; /IHS/OIT/RAM - Here's the "fun part" - we have to account for when the Medicaid pointer is fixed, and if not find the data manually.
+28 ; If the Eligability IEN exists, populate the .06 field.
IF +ABSPELIGIEN>0
SET $PIECE(ABSPRETURN,U,6)=ABSPELIGIEN
+29 ; If the Medicaid multiple is correct (a 7-digit FileMan date) populate the field.
IF ABSPMULT?7N
SET $PIECE(ABSPRETURN,U,7)=ABSPMULT
+30 ; If not... we have some work to do. Let's go find the correct multiple.
IF '$TEST
Begin DoDot:3
+31 SET I=""
SET GO=1
FOR
SET I=$ORDER(^AUPNMCD(ABSPELIGIEN,11,I),-1)
IF I=""!('GO)
QUIT
Begin DoDot:4
+32 SET BEG=$PIECE($GET(^AUPNMCD(ABSPELIGIEN,11,I,0)),U,1)
SET END=$PIECE($GET(^AUPNMCD(ABSPELIGIEN,11,I,0)),U,2)
+33 WRITE "ABSPTODAY: ",ABSPTODAY," TESTING: ",I," BEG: ",BEG," END: ",END,!
+34 ; If "Today" is after the beginning date and there is no end date, this is an eligible multiple, store it and exit loop.
IF (BEG<=ABSPTODAY)&(+END=0)
WRITE "FLERM.",!
SET GO=0
SET $PIECE(ABSPRETURN,U,7)=I
QUIT
+35 ; If "Today" is between the eligible dates, this is an eligible multiple, store it and exit loop.
IF (BEG<=ABSPTODAY)&(ABSPTODAY<END)
SET GO=0
SET $PIECE(ABSPRETURN,U,7)=I
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+36 ; That _should_ be all of the available data to send to 3PB; let's clean up the room and head back...
+37 ; RETURN DATA IS IN SAME FORM / ORDER AS THE 13 MULTIPLE NEEDS IN FILE 9002274.3:
+38 ; .01 / INSURER; .04 / MEDICARE MULTIPLE ; .05 / RAILROAD MULTIPLE ; .06 / MEDICAID ELIG POINTER
+39 ; .07 / MEDICAID MULTIPLE ; .08 / PRIVATE INSURANCE MULTIPLE
+40 QUIT ABSPRETURN
+41 ; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - End of new code detailed above.
