ABSP5B2 ; IHS/OIT/CASSevern/Pieran ran 1/19/2011 - Handling of NCPDP Reversal "B2" Claims for 5.1
;;1.0;PHARMACY POINT OF SALE;**42,43**;JUN 21, 2001;Build 38
;
;
; SO FAR THIS IS JUST A COPY OF ABSPB1 "BILLING" TRANSACTION....MOST OF BELOW CODE WILL BE REPLACED!!!
; This routine will replace the ABSPOSCF for 5.1, so that we no
; longer need to use the formats file.
; This will go through and get the data for each and every segment and field
; format it and place it in the CLAIM file ^ABSPC(CLAIMIEN
; The ABSP() Array is already set up in: GETINFO^ABSPOSCC before we get here.
;INPUT = ACTION
; "CLAIMHD" = Set up only the claim header for creating ^ABSPC entry
; "CLAIMRST" = Set up Rest of Claim info and fill in ^ABSPC entry
; "OUTHD" = Create the actual Output HEADER Record
; "OUTRST" = Create the actual Output Rest of the Record.
EN(ACTION,MEDN,IEN) ;EP
N INSARRAY,DO,SPECIAL,SUPPRESS
S RECORD=$G(RECORD)
I ACTION["CLAIM" D
. S DO=ABSP("Insurer","IEN")_","
ELSE D
. S DO=IEN("9002313.4")_","
D GETS^DIQ(9002313.4,DO,"100.15;100.16;100.17;200.01;210*;215*;220*","","INSARRAY")
I $D(INSARRAY(9002313.42)) D SETSPEC
I $D(INSARRAY(9002313.46)) D SETSUPR
D CHECKOVER^ABSP5B1F(D0,.SPECIAL) ;Check for Manual Over-Rides for this Claim
;I $D(SPECIAL) D ADDSEG^ABSPB1F(.SPECIAL,.ADDSEG) ;Figure out based on Special fields which segments we need
I (ACTION="CLAIMHD")!(ACTION="OUTHD") D
. D HEADER ;Every time
. D INSURANCE ;Every time;IHS/OIT/CASSevern/Pieran/RCS; Patch 43 - Add back in
I (ACTION="CLAIMRST")!(ACTION="OUTRST") D
. I +$G(IEN(9002313.01))=0 S IEN(9002313.01)=1
. D CLAIM^ABSP5B2A ;Every time
. ;D PRICING^ABSP5B2A ;Pretty much every time
. I $D(ADDSEG("DURRPPS")) D DURRPPS^ABSP5B2A ;Very common...but for over-rides only
Q
;Go through field by field and construct the Header
;The header is the one segment that is completely unchanged between version 5.1 and D.0
;The only difference is field 102 "VERSION" now says D0 instead of 51
N FIELD
F FIELD=101,102,103,104,109,202,201,401,110 D
. Q:$D(SUPPRESS(FIELD))
. I (ACTION["CLAIM"),(FIELD'=111) D
. . D @(FIELD_"GET")
. . D @(FIELD_"FMT")
. . D @(FIELD_"SET")
. ELSE D @(FIELD_"APD")
Q
;BIN #
101GET I '$D(SPECIAL(101)) S ABSP("X")=$G(INSARRAY(9002313.4,DO,100.16))
ELSE X SPECIAL(101)
Q
101FMT S ABSP("X")=$$NFF^ABSPECFM(ABSP("X"),6)
Q
101SET S $P(^ABSPC(ABSP(9002313.02),100),U,1)=ABSP("X")
Q
101APD S RECORD=$G(ABSP(9002313.02,MEDN,FIELD,"I"))
Q
;VERSION (5.1, D.0)
102GET S ABSP("X")=$TR($G(INSARRAY(9002313.4,DO,100.15)),".","")
Q
102FMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
Q
102SET S $P(^ABSPC(ABSP(9002313.02),100),U,2)=ABSP("X")
Q
102APD S RECORD=RECORD_$G(ABSP(9002313.02,MEDN,FIELD,"I"))
Q
;TRANSACTION CODE "B2" for Reversal
103GET S ABSP("X")="B2"
Q
103FMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
Q
103SET S $P(^ABSPC(ABSP(9002313.02),100),U,3)=ABSP("X")
Q
103APD S RECORD=RECORD_"B2"
Q
;PCN #
104GET I '$D(SPECIAL(104)) S ABSP("X")=$G(INSARRAY(9002313.4,DO,100.17))
ELSE X SPECIAL(104)
Q
104FMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),10)
Q
104SET S $P(^ABSPC(ABSP(9002313.02),100),U,4)=ABSP("X")
Q
104APD S RECORD=RECORD_$G(ABSP(9002313.02,MEDN,FIELD,"I"))
Q
;Transaction count
109GET I '$D(SPECIAL(109)) S ABSP("X")=1 ;IHS/OIT/CASSevern/Pieran/RCS; Patch 43 - Force to a '1'
ELSE X SPECIAL(109)
Q
109FMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),1)
Q
109SET S $P(^ABSPC(ABSP(9002313.02),100),U,9)=ABSP("X")
Q
109APD S RECORD=RECORD_1 ;IHS/OIT/CASSevern/Pieran/RCS; Patch 43 - Force to '1'
Q
;Service provider ID
202GET I '$D(SPECIAL(202)) S ABSP("X")=$G(ABSP("Header","Service Prov ID Qual"))
ELSE X SPECIAL(202)
Q
202FMT S ABSP("X")=$$ANFF^ABSPECFM($G(ABSP("X")),2)
Q
202SET S $P(^ABSPC(ABSP(9002313.02),200),U,2)=ABSP("X")
Q
202APD S RECORD=RECORD_$G(ABSP(9002313.02,MEDN,FIELD,"I"))
Q
;Pharmacy number
201GET I '$D(SPECIAL(201)) S ABSP("X")=$G(ABSP("Site","Pharmacy #"))
ELSE X SPECIAL(201)
Q
201FMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),15)
Q
201SET S $P(^ABSPC(ABSP(9002313.02),200),U,1)=ABSP("X")
Q
201APD S RECORD=RECORD_$G(ABSP(9002313.02,MEDN,FIELD,"I"))
Q
;Fill Date
401GET I '$D(SPECIAL(401)) S ABSP("X")=$G(ABSP("RX","Date Filled"))
ELSE X SPECIAL(401)
Q
401FMT S ABSP("X")=$$NFF^ABSPECFM($$DTF1^ABSPECFM(ABSP("X")),8)
Q
401SET S $P(^ABSPC(ABSP(9002313.02),401),U,1)=ABSP("X")
Q
401APD S RECORD=RECORD_$G(ABSP(9002313.02,MEDN,FIELD,"I"))
Q
;Vendor ID
110GET I '$D(SPECIAL(110)) S ABSP("X")=$G(ABSP("Software Vendor"))
ELSE X SPECIAL(110)
Q
110FMT S ABSP("X")=$$ANFF^ABSPECFM($G(ABSP("X")),10)
Q
110SET S $P(^ABSPC(ABSP(9002313.02),100),U,10)=ABSP("X")
Q
110APD S RECORD=RECORD_$G(ABSP(9002313.02,MEDN,FIELD,"I"))
Q
INSURANCE ;INSURANCE Segment
N FIELD
S RECORD=$G(RECORD)
F FIELD="111",302,301,359 D
. Q:$D(SUPPRESS(FIELD))
. I (ACTION["CLAIM"),(FIELD'=111) D
. . D @(FIELD_"GET")
. . D @(FIELD_"FMT")
. . D @(FIELD_"SET")
. ELSE D APPEND(FIELD)
Q
;Segment identifier
111GET S ABSP("X")="04"
Q
111FMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
Q
111SET ;This isn't used for the 111 Field
Q
;Cardholder ID
302GET I '$D(SPECIAL(302)) S ABSP("X")=$G(ABSP("Insurer","Policy #"))
ELSE X SPECIAL(302)
Q
302FMT S:ABSP("X")'="" ABSP("X")="C2"_$$ANFF^ABSPECFM($G(ABSP("X")),20)
Q
302SET S $P(^ABSPC(ABSP(9002313.02),300),U,2)=ABSP("X")
Q
;Group ID
301GET I '$D(SPECIAL(301)) S ABSP("X")=$G(ABSP("Insurer","Group #"))
ELSE X SPECIAL(301)
Q
301FMT S:ABSP("X")'="" ABSP("X")="C1"_$$ANFF^ABSPECFM(ABSP("X"),15)
Q
301SET S $P(^ABSPC(ABSP(9002313.02),300),U,1)=ABSP("X")
Q
;Medigap ID
359GET I '$D(SPECIAL(359)) S ABSP("X")=""
ELSE X SPECIAL(359)
Q
359FMT S:ABSP("X")'="" ABSP("X")="2A"_$$ANFF^ABSPECFM($G(ABSP("X")),20)
Q
359SET ;Not Yet Implemented **
Q
SETSPEC ;SET UP SPECIAL CODE ARRAY HERE.
N D1,NCODE,MUMPS
S D1=""
F S D1=$O(INSARRAY(9002313.42,D1)) Q:D1="" D
. S NCODE=$G(INSARRAY(9002313.42,D1,.01))
. S MUMPS=$G(INSARRAY(9002313.42,D1,.02))
. I MUMPS'["ABSP(""X"")" S MUMPS="S ABSP(""X"")="""_MUMPS_""""
. S SPECIAL(NCODE)=MUMPS
Q
SETSUPR ;SET UP SUPPRESS CODE ARRAY HERE
N D1,SCODE
S D1=""
F S D1=$O(INSARRAY(9002313.46,D1)) Q:D1="" D
. S SCODE=$G(INSARRAY(9002313.46,D1,.01))
. S SUPPRESS(SCODE)=""
Q
APPEND(FIELD) ;This is where outgoing record is built field by field
I FIELD["111" D
. D @(FIELD_"GET")
. D @(FIELD_"FMT")
. S RECORD=RECORD_$C(30,28)_"AM"_ABSP("X")
ELSE D
. I $G(ABSP(9002313.02,MEDN,FIELD,"I"))'="" S RECORD=RECORD_$C(28)_$G(ABSP(9002313.02,MEDN,FIELD,"I"))
. ELSE I $D(SPECIAL(FIELD)) D
. . X SPECIAL(FIELD)
. . D @(FIELD_"FMT")
. . S RECORD=RECORD_$C(28)_ABSP("X")
Q
ABSP5B2 ; IHS/OIT/CASSevern/Pieran ran 1/19/2011 - Handling of NCPDP Reversal "B2" Claims for 5.1
+1 ;;1.0;PHARMACY POINT OF SALE;**42,43**;JUN 21, 2001;Build 38
+2 ;
+3 ;
+4 ; SO FAR THIS IS JUST A COPY OF ABSPB1 "BILLING" TRANSACTION....MOST OF BELOW CODE WILL BE REPLACED!!!
+5 ; This routine will replace the ABSPOSCF for 5.1, so that we no
+6 ; longer need to use the formats file.
+7 ; This will go through and get the data for each and every segment and field
+8 ; format it and place it in the CLAIM file ^ABSPC(CLAIMIEN
+9 ; The ABSP() Array is already set up in: GETINFO^ABSPOSCC before we get here.
+10 ;INPUT = ACTION
+11 ; "CLAIMHD" = Set up only the claim header for creating ^ABSPC entry
+12 ; "CLAIMRST" = Set up Rest of Claim info and fill in ^ABSPC entry
+13 ; "OUTHD" = Create the actual Output HEADER Record
+14 ; "OUTRST" = Create the actual Output Rest of the Record.
EN(ACTION,MEDN,IEN) ;EP
+1 NEW INSARRAY,DO,SPECIAL,SUPPRESS
+2 SET RECORD=$GET(RECORD)
+3 IF ACTION["CLAIM"
Begin DoDot:1
+4 SET DO=ABSP("Insurer","IEN")_","
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET DO=IEN("9002313.4")_","
End DoDot:1
+7 DO GETS^DIQ(9002313.4,DO,"100.15;100.16;100.17;200.01;210*;215*;220*","","INSARRAY")
+8 IF $DATA(INSARRAY(9002313.42))
DO SETSPEC
+9 IF $DATA(INSARRAY(9002313.46))
DO SETSUPR
+10 ;Check for Manual Over-Rides for this Claim
DO CHECKOVER^ABSP5B1F(D0,.SPECIAL)
+11 ;I $D(SPECIAL) D ADDSEG^ABSPB1F(.SPECIAL,.ADDSEG) ;Figure out based on Special fields which segments we need
+12 IF (ACTION="CLAIMHD")!(ACTION="OUTHD")
Begin DoDot:1
+13 ;Every time
DO HEADER
+14 ;Every time;IHS/OIT/CASSevern/Pieran/RCS; Patch 43 - Add back in
DO INSURANCE
End DoDot:1
+15 IF (ACTION="CLAIMRST")!(ACTION="OUTRST")
Begin DoDot:1
+16 IF +$GET(IEN(9002313.01))=0
SET IEN(9002313.01)=1
+17 ;Every time
DO CLAIM^ABSP5B2A
+18 ;D PRICING^ABSP5B2A ;Pretty much every time
+19 ;Very common...but for over-rides only
IF $DATA(ADDSEG("DURRPPS"))
DO DURRPPS^ABSP5B2A
End DoDot:1
+20 QUIT
+21 ;Go through field by field and construct the Header
+22 ;The header is the one segment that is completely unchanged between version 5.1 and D.0
+23 ;The only difference is field 102 "VERSION" now says D0 instead of 51
+1 NEW FIELD
+2 FOR FIELD=101,102,103,104,109,202,201,401,110
Begin DoDot:1
+3 IF $DATA(SUPPRESS(FIELD))
QUIT
+4 IF (ACTION["CLAIM")
IF (FIELD'=111)
Begin DoDot:2
+5 DO @(FIELD_"GET")
+6 DO @(FIELD_"FMT")
+7 DO @(FIELD_"SET")
End DoDot:2
+8 IF '$TEST
DO @(FIELD_"APD")
End DoDot:1
+9 QUIT
+10 ;BIN #
101GET IF '$DATA(SPECIAL(101))
SET ABSP("X")=$GET(INSARRAY(9002313.4,DO,100.16))
+1 IF '$TEST
XECUTE SPECIAL(101)
+2 QUIT
101FMT SET ABSP("X")=$$NFF^ABSPECFM(ABSP("X"),6)
+1 QUIT
101SET SET $PIECE(^ABSPC(ABSP(9002313.02),100),U,1)=ABSP("X")
+1 QUIT
101APD SET RECORD=$GET(ABSP(9002313.02,MEDN,FIELD,"I"))
+1 QUIT
+2 ;VERSION (5.1, D.0)
102GET SET ABSP("X")=$TRANSLATE($GET(INSARRAY(9002313.4,DO,100.15)),".","")
+1 QUIT
102FMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
102SET SET $PIECE(^ABSPC(ABSP(9002313.02),100),U,2)=ABSP("X")
+1 QUIT
102APD SET RECORD=RECORD_$GET(ABSP(9002313.02,MEDN,FIELD,"I"))
+1 QUIT
+2 ;TRANSACTION CODE "B2" for Reversal
103GET SET ABSP("X")="B2"
+1 QUIT
103FMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
103SET SET $PIECE(^ABSPC(ABSP(9002313.02),100),U,3)=ABSP("X")
+1 QUIT
103APD SET RECORD=RECORD_"B2"
+1 QUIT
+2 ;PCN #
104GET IF '$DATA(SPECIAL(104))
SET ABSP("X")=$GET(INSARRAY(9002313.4,DO,100.17))
+1 IF '$TEST
XECUTE SPECIAL(104)
+2 QUIT
104FMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),10)
+1 QUIT
104SET SET $PIECE(^ABSPC(ABSP(9002313.02),100),U,4)=ABSP("X")
+1 QUIT
104APD SET RECORD=RECORD_$GET(ABSP(9002313.02,MEDN,FIELD,"I"))
+1 QUIT
+2 ;Transaction count
109GET ;IHS/OIT/CASSevern/Pieran/RCS; Patch 43 - Force to a '1'
IF '$DATA(SPECIAL(109))
SET ABSP("X")=1
+1 IF '$TEST
XECUTE SPECIAL(109)
+2 QUIT
109FMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),1)
+1 QUIT
109SET SET $PIECE(^ABSPC(ABSP(9002313.02),100),U,9)=ABSP("X")
+1 QUIT
109APD ;IHS/OIT/CASSevern/Pieran/RCS; Patch 43 - Force to '1'
SET RECORD=RECORD_1
+1 QUIT
+2 ;Service provider ID
202GET IF '$DATA(SPECIAL(202))
SET ABSP("X")=$GET(ABSP("Header","Service Prov ID Qual"))
+1 IF '$TEST
XECUTE SPECIAL(202)
+2 QUIT
202FMT SET ABSP("X")=$$ANFF^ABSPECFM($GET(ABSP("X")),2)
+1 QUIT
202SET SET $PIECE(^ABSPC(ABSP(9002313.02),200),U,2)=ABSP("X")
+1 QUIT
202APD SET RECORD=RECORD_$GET(ABSP(9002313.02,MEDN,FIELD,"I"))
+1 QUIT
+2 ;Pharmacy number
201GET IF '$DATA(SPECIAL(201))
SET ABSP("X")=$GET(ABSP("Site","Pharmacy #"))
+1 IF '$TEST
XECUTE SPECIAL(201)
+2 QUIT
201FMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),15)
+1 QUIT
201SET SET $PIECE(^ABSPC(ABSP(9002313.02),200),U,1)=ABSP("X")
+1 QUIT
201APD SET RECORD=RECORD_$GET(ABSP(9002313.02,MEDN,FIELD,"I"))
+1 QUIT
+2 ;Fill Date
401GET IF '$DATA(SPECIAL(401))
SET ABSP("X")=$GET(ABSP("RX","Date Filled"))
+1 IF '$TEST
XECUTE SPECIAL(401)
+2 QUIT
401FMT SET ABSP("X")=$$NFF^ABSPECFM($$DTF1^ABSPECFM(ABSP("X")),8)
+1 QUIT
401SET SET $PIECE(^ABSPC(ABSP(9002313.02),401),U,1)=ABSP("X")
+1 QUIT
401APD SET RECORD=RECORD_$GET(ABSP(9002313.02,MEDN,FIELD,"I"))
+1 QUIT
+2 ;Vendor ID
110GET IF '$DATA(SPECIAL(110))
SET ABSP("X")=$GET(ABSP("Software Vendor"))
+1 IF '$TEST
XECUTE SPECIAL(110)
+2 QUIT
110FMT SET ABSP("X")=$$ANFF^ABSPECFM($GET(ABSP("X")),10)
+1 QUIT
110SET SET $PIECE(^ABSPC(ABSP(9002313.02),100),U,10)=ABSP("X")
+1 QUIT
110APD SET RECORD=RECORD_$GET(ABSP(9002313.02,MEDN,FIELD,"I"))
+1 QUIT
INSURANCE ;INSURANCE Segment
+1 NEW FIELD
+2 SET RECORD=$GET(RECORD)
+3 FOR FIELD="111",302,301,359
Begin DoDot:1
+4 IF $DATA(SUPPRESS(FIELD))
QUIT
+5 IF (ACTION["CLAIM")
IF (FIELD'=111)
Begin DoDot:2
+6 DO @(FIELD_"GET")
+7 DO @(FIELD_"FMT")
+8 DO @(FIELD_"SET")
End DoDot:2
+9 IF '$TEST
DO APPEND(FIELD)
End DoDot:1
+10 QUIT
+11 ;Segment identifier
111GET SET ABSP("X")="04"
+1 QUIT
111FMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
111SET ;This isn't used for the 111 Field
+1 QUIT
+2 ;Cardholder ID
302GET IF '$DATA(SPECIAL(302))
SET ABSP("X")=$GET(ABSP("Insurer","Policy #"))
+1 IF '$TEST
XECUTE SPECIAL(302)
+2 QUIT
302FMT IF ABSP("X")'=""
SET ABSP("X")="C2"_$$ANFF^ABSPECFM($GET(ABSP("X")),20)
+1 QUIT
302SET SET $PIECE(^ABSPC(ABSP(9002313.02),300),U,2)=ABSP("X")
+1 QUIT
+2 ;Group ID
301GET IF '$DATA(SPECIAL(301))
SET ABSP("X")=$GET(ABSP("Insurer","Group #"))
+1 IF '$TEST
XECUTE SPECIAL(301)
+2 QUIT
301FMT IF ABSP("X")'=""
SET ABSP("X")="C1"_$$ANFF^ABSPECFM(ABSP("X"),15)
+1 QUIT
301SET SET $PIECE(^ABSPC(ABSP(9002313.02),300),U,1)=ABSP("X")
+1 QUIT
+2 ;Medigap ID
359GET IF '$DATA(SPECIAL(359))
SET ABSP("X")=""
+1 IF '$TEST
XECUTE SPECIAL(359)
+2 QUIT
359FMT IF ABSP("X")'=""
SET ABSP("X")="2A"_$$ANFF^ABSPECFM($GET(ABSP("X")),20)
+1 QUIT
359SET ;Not Yet Implemented **
+1 QUIT
SETSPEC ;SET UP SPECIAL CODE ARRAY HERE.
+1 NEW D1,NCODE,MUMPS
+2 SET D1=""
+3 FOR
SET D1=$ORDER(INSARRAY(9002313.42,D1))
IF D1=""
QUIT
Begin DoDot:1
+4 SET NCODE=$GET(INSARRAY(9002313.42,D1,.01))
+5 SET MUMPS=$GET(INSARRAY(9002313.42,D1,.02))
+6 IF MUMPS'["ABSP(""X"")"
SET MUMPS="S ABSP(""X"")="""_MUMPS_""""
+7 SET SPECIAL(NCODE)=MUMPS
End DoDot:1
+8 QUIT
SETSUPR ;SET UP SUPPRESS CODE ARRAY HERE
+1 NEW D1,SCODE
+2 SET D1=""
+3 FOR
SET D1=$ORDER(INSARRAY(9002313.46,D1))
IF D1=""
QUIT
Begin DoDot:1
+4 SET SCODE=$GET(INSARRAY(9002313.46,D1,.01))
+5 SET SUPPRESS(SCODE)=""
End DoDot:1
+6 QUIT
APPEND(FIELD) ;This is where outgoing record is built field by field
+1 IF FIELD["111"
Begin DoDot:1
+2 DO @(FIELD_"GET")
+3 DO @(FIELD_"FMT")
+4 SET RECORD=RECORD_$CHAR(30,28)_"AM"_ABSP("X")
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 IF $GET(ABSP(9002313.02,MEDN,FIELD,"I"))'=""
SET RECORD=RECORD_$CHAR(28)_$GET(ABSP(9002313.02,MEDN,FIELD,"I"))
+7 IF '$TEST
IF $DATA(SPECIAL(FIELD))
Begin DoDot:2
+8 XECUTE SPECIAL(FIELD)
+9 DO @(FIELD_"FMT")
+10 SET RECORD=RECORD_$CHAR(28)_ABSP("X")
End DoDot:2
End DoDot:1
+11 QUIT
