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