Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPOS03

ABSPOS03.m

Go to the documentation of this file.
  1. ABSPOS03 ; IHS/FCS/DRS - 9002313.03 utilities ; [ 09/17/2002 10:04 AM ]
  1. ;;1.0;PHARMACY POINT OF SALE;**3,42,43,48**;JUN 21, 2001;Build 38
  1. ;-----------------------------------------------------------
  1. ;IHS/SD/lwj 9/11/02 When running this report, the sites
  1. ; were encountering an undefined error. The error was caused
  1. ; by insurers being used on claims, and then removed from the
  1. ; ABSP INSURER file. This can only be done by either someone
  1. ; at the programmer level, or site manager level, and should
  1. ; not be done. The fix was to simply $g the retrieval code.
  1. ;-----------------------------------------------------------
  1. Q
  1. ; General utilities for retrieval from 9002313.03, Claim Response
  1. ; $$INSPAID is used by ABSPOSQL
  1. INSPAID(N) ;EP - from ABSPOSQL - total amount paid by insurer
  1. N RX,TOT,X S (TOT,RX)=0
  1. F S RX=$O(^ABSPR(N,1000,RX)) Q:'RX D
  1. . ; Try Gross Amount Due, and if that's zero, Usual and Customary
  1. . S X=$$INSPAID1(N,RX)
  1. . S TOT=TOT+X
  1. Q
  1. INSPAID1(N,RX) ;EP -
  1. N X S X=$$509(N,RX) Q X
  1. NETPAID1(N,RX) ; EP - computed field in 9002313.57
  1. N X S X=$$509(N,RX) ; X = (#509) Total Amount Paid
  1. N SUB S SUB=1 ; Do we need to subtract (#505) Patient Pay Amount?
  1. ;N IEN02,INS,FMT S IEN02=$P(^ABSPR(RESP,0),U)
  1. N IEN02,INS,FMT S IEN02=$P($G(^ABSPR(RESP,0)),U)
  1. N ZERR ; /IHS/OIT/RAM ; 9 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
  1. I IEN02 D
  1. . ;IHS/SD/lwj 9/11/02 next two lines remarked out - following 2 added
  1. . ;S INS=$P(^ABSPC(IEN02,0),U,2) Q:'INS ;IHS/SD/lwj 9/11/02
  1. . ;S FMT=$P(^ABSPEI(INS,100),U) Q:'FMT ;IHS/SD/lwj 9/11/02
  1. . S INS=$P($G(^ABSPC(IEN02,0)),U,2) Q:'INS ;IHS/SD/lwj 9/11/02
  1. . ;IHS/OIT/CASSEVER/RAN 03/24/2011 patch 42 Get rid of references to formats for new method of claims processing START
  1. . ;IHS/OIT/CASSEVERN/RAN 01/09/2012 patch 43, fix use of variable X
  1. . I $G(^ABSP(9002313.99,1,"ABSPICNV"))=1 D
  1. . . N X S X=$$GET1^DIQ(9002313.4,INS_",",100.4,"I")
  1. . . I X S SUB=0
  1. . ELSE D
  1. . . S FMT=$P($G(^ABSPEI(INS,100)),U) Q:'FMT ;IHS/SD/lwj 9/11/02
  1. . . N X S X=$P(^ABSPF(9002313.92,FMT,1),U,10)
  1. . . I X S SUB=0 ; Total paid means total paid by insurance
  1. I SUB S X=X-$$505(N,RX)
  1. I X<0,SUB D ; apparently this format is supposed to be excl.
  1. . I ($G(^ABSP(9002313.99,1,"ABSPICNV"))=1),IEN02 D
  1. . . S INS=$P($G(^ABSPC(IEN02,0)),U,2)
  1. . . S INS(1,9002313.4,INS_",",100.4)=1
  1. . . ; D UPDATE^DIE("","INS(1)")
  1. . . D UPDATE^DIE("","INS(1)",,"ZERR") ; /IHS/OIT/RAM ; 9 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
  1. . . I $D(ZERR) D LOG^ABSPOSL2("NETPAID1^ABSPOS03",.ZERR) ; /IHS/OIT/RAM ; 9 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1. . ELSE D
  1. . . Q:'FMT
  1. . . S $P(^ABSPF(9002313.92,FMT,1),U,10)=1
  1. . ;IHS/OIT/CASSEVER/RAN 03/24/2011 patch 42 Get rid of references to formats for new method of claims processing END
  1. . S X=X+$$505(N,RX) ;*1.26*1*
  1. Q X
  1. REJTEXT(RESP,POS,ARR) ; EP - fills array (passed by ref)
  1. K ARR
  1. N A,I,X,R S (A,I)=0
  1. F S A=$O(^ABSPR(RESP,1000,POS,511,A)) Q:'A D
  1. . S R=$P(^ABSPR(RESP,1000,POS,511,A,0),U)
  1. . Q:R=""
  1. . N S S S=$O(^ABSPF(9002313.93,"B",R,0))
  1. . I S S X=$TR($G(^ABSPF(9002313.93,S,0)),U,":")
  1. . E S X=R_" unrecognized reject code"
  1. . S I=I+1,ARR(I)=X
  1. Q
  1. MESSAGE(RESP,POS,N) ; EP - get additional message from response
  1. I $G(N)=1 Q $P($G(^ABSPR(RESP,1000,POS,504)),U)
  1. I $G(N)=2 Q $P($G(^ABSPR(RESP,1000,POS,526)),U)
  1. Q $$MESSAGE(RESP,POS,1)_$$MESSAGE(RESP,POS,2)
  1. DFF2EXT(X) Q $$DFF2EXT^ABSPECFM(X)
  1. 505(M,N) Q $$500(M,N,5) ; Patient Pay Amount
  1. 506(M,N) Q $$500(M,N,6) ; Ingredient Cost Paid
  1. 507(M,N) Q $$500(M,N,7) ; Contract Fee Paid
  1. 508(M,N) Q $$500(M,N,8) ; Sales Tax Paid
  1. 509(M,N) Q $$500(M,N,9) ; Total Amount Paid
  1. 512(M,N) Q $$500(M,N,12) ; Accumulated Deductible Amount
  1. 513(M,N) Q $$500(M,N,13) ; Remaining Deductible Amount
  1. 514(M,N) Q $$500(M,N,14) ; Remaining Benefit Amount
  1. 517(M,N) Q $$500(M,N,17) ; Amt Applied to Periodic Deduct
  1. 518(M,N) Q $$500(M,N,18) ; Amount of Copay/CoInsurance
  1. 519(M,N) Q $$500(M,N,19) ; Amt Attrib to Prod Selection
  1. 520(M,N) Q $$500(M,N,20) ; Amt Exceed Per Benefit Max
  1. 521(M,N) Q $$500(M,N,21) ; Incentive Fee Paid
  1. 523(M,N) Q $$500(M,N,23) ; Amount Attributed to Sales Tax
  1. 500(M,N,J) ; field #500+J signed numeric
  1. Q:'M!'N ""
  1. N X S X=$P($G(^ABSPR(M,1000,N,500)),U,J)
  1. I $E(X,1,2)?2U S X=$E(X,3,$L(X))
  1. S X=$$DFF2EXT(X)
  1. Q X