- 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