ABSPOSH6 ;IHS/SD/lwj - NCPDP 5.1 Post 5.1 response [ 09/04/2002 12:57 PM ]
;;1.0;PHARMACY POINT OF SALE;**3,9,39,42,43**;JUN 21, 2001;Build 38
;-------------------------------------------------------------
; Originally, the entire response was processed in the
; ABSPOSH5 routine - but it exceed SAC limitations on
; routine size - so the processing of some of the transaction
; level information was moved to this routine. Other portions
; were moved to the ABSPOSH7 routine.
;
; This routine is called solely from ABSPOSH5.
;
;--------------------------------------------------------------
;IHS/SD/lwj 01/22/04 Patch 9
; In January 2004, BC/BS Oklahoma and WebMD allowed responses
; to be returned that indicated multiple rejection codes, when
; in fact only a single rejection code was being returned. This
; caused problems, as we had followed the HIPAA standards that
; said that the count should match the number of rejection codes.
; While the issue was raised to WebMD that they were out of
; compliance, we still made changes to our code just in case
; they allowed others through.
; The change was originate by POC in Oklahoma.
;--------------------------------------------------------------
;
Q
;
RESPSTS ;EP - NCPDP 5.1 response processing (moved from ABSPOSH5)
; called from WRTTRAN^ABSPOSH5
; MEDN is set in ABSPOSH5 in the WRTTRAN subroutine
; process the response status segment - here's the fields we MIGHT
; encounter:
; 112 - transaction response status (mandatory)
; 503 - authorization number
; 510 - reject count
; 511 - reject code (repeating field)
; 546 - reject field occurrence indicator (repeating field)
; 547 - approved message code count
; 548 - approved message code (repeating field)
; 526 - additional message information
; 549 - help desk phone number qualifier
; 550 - help desk phone number
;
; *special note - in 3.2 the transaction response is stored in field
; 501 at the prescription level. In 5.1 that was moved to field 112.
; All the reports are based on the 501 field, so to keep things
; simple, we will simply update both the 112 and 501 fields with
; the transaction level response status.
;
S $P(^ABSPR(RESPIEN,1000,INDEX,110),U,2)=$G(FDATA("M",MEDN,112))
S $P(^ABSPR(RESPIEN,1000,INDEX,500),U)=$G(FDATA("M",MEDN,112)) ;501
S $P(^ABSPR(RESPIEN,1000,INDEX,500),U,3)=$G(FDATA("M",MEDN,503))
;
; process reject information if there
S $P(^ABSPR(RESPIEN,1000,INDEX,500),U,10)=$G(FDATA("M",MEDN,510))
I $D(FDATA("M",MEDN,510)) D REPREJ ;process the rejection codes
;
; process approved information if there
S $P(^ABSPR(RESPIEN,1000,INDEX,540),U,7)=$G(FDATA("M",MEDN,547))
I $D(FDATA("M",MEDN,547)) D REPAPP ;process the repeating fld
;
; finish up with the additional message, and help desk information
;IHS/OIT/CASSevern/Pieran/RAN 11-28-2011 42 making field 526 a repeating field
;S $P(^ABSPR(RESPIEN,1000,INDEX,526),U)=$G(FDATA("M",MEDN,526))
I $D(FDATA("M",MEDN,526)) D REPADM ;process additional messages
S $P(^ABSPR(RESPIEN,1000,INDEX,540),U,9)=$G(FDATA("M",MEDN,549))
S $P(^ABSPR(RESPIEN,1000,INDEX,540),U,10)=$G(FDATA("M",MEDN,550))
;
;
Q
;
REPREJ ; This subroutine will process the reject repeating fields
; that are a part of the status segment.
; Two fields here - 511 - Reject Code and
; 546 - Reject field occurrence indicator
;
N CNTR,COUNT,RJCD,RJOC,RLCNT
;
S RLCNT=0
S COUNT=$G(FDATA("M",MEDN,510)) ;reject count
Q:COUNT'>0
;
F CNTR=1:1:COUNT D
. S (RJCD,RJOC)=""
. S RJCD=$G(FDATA("M",MEDN,511,CNTR)) ;rejection code
. ;IHS/OIT/CNI/RAN 5/21/2010 Patch 39 Strip out unwanted spaces being sent by EMDEON
. S RJCD=$TR(RJCD," ","")
. S RJOC=$G(FDATA("M",MEDN,546,CNTR)) ;reject fld occurence ind
. ;IHS/SD/lwj 1/22/04 patch 9 nxt line remarked out, following
. ; added
. ;I $D(RJCD) D
. I $G(RJCD)]"" D
.. S $P(^ABSPR(RESPIEN,1000,INDEX,511,CNTR,0),U)=RJCD
.. S ^ABSPR(RESPIEN,1000,INDEX,511,"B",RJCD,CNTR)=""
. ;IHS/SD/lwj 1/22/04 patch 9 nxt two lns remkd out, nxt 2 added
. ;S:$D(RJOC) $P(^ABSPR(RESPIEN,1000,INDEX,511,CNTR,0),U,2)=RJOC
. ;S:(($D(RJOC))!($D(RJCD))) RLCNT=RLCNT+1
. S:$G(RJOC)]"" $P(^ABSPR(RESPIEN,1000,INDEX,511,CNTR,0),U,2)=RJOC
. S:(($G(RJOC)]"")!($G(RJCD)]"")) RLCNT=RLCNT+1
;
I RLCNT>0 D
. S ^ABSPR(RESPIEN,1000,INDEX,511,0)="^9002313.03511A^"_RLCNT_"^"_RLCNT
;
Q
;
;
REPAPP ; This subroutine will process the approved repeating field
; that is a part of the status segment.
; Field 548 - Approved Message Code
;
N CNTR,COUNT,RLCNT,APP
;
S RLCNT=0
S COUNT=$G(FDATA("M",MEDN,547)) ;approved message code count
Q:COUNT'>0
;
F CNTR=1:1:COUNT D
. S APP=$G(FDATA("M",MEDN,548,CNTR)) ;approved message code
. I $L(APP) D
.. S $P(^ABSPR(RESPIEN,1000,INDEX,548,CNTR,0),U)=APP
.. S ^ABSPR(RESPIEN,1000,INDEX,548,"B",APP,CNTR)=""
.. S RLCNT=RLCNT+1
;
I RLCNT>0 D
. S ^ABSPR(RESPIEN,1000,INDEX,548,0)="^9002313.301548A^"_RLCNT_"^"_RLCNT
;
Q
;
RESPCLM ;EP - NCPDP 5.1 response processing (moved from ABSPOSH5)
; called from WRTTRAN^ABSPOSH5
; MEDN is set in ABSPOSH5 in the WRTTRAN subroutine
; process the response claim segment - here's the fields we MIGHT
; encounter:
; 455 - prescription/service reference number qualifier
; 402 - prescripton/service reference number
; 551 - preferred product count
; 552 - preferred product id qualifier (repeating)
; 553 - preferred product id (repeating)
; 554 - preferred product incentive (repeating)
; 555 - preferred product copay incentive (repeating)
; 556 - preferred product description (repeating)
;
; start with what are suppose to be mandatory fields
S $P(^ABSPR(RESPIEN,1000,INDEX,450),U,5)=$G(FDATA("M",MEDN,455))
S $P(^ABSPR(RESPIEN,1000,INDEX,400),U,2)=$G(FDATA("M",MEDN,402))
;
; now lets try to process the preferred product repeating fields
S $P(^ABSPR(RESPIEN,1000,INDEX,550),U)=$G(FDATA("M",MEDN,551))
I $D(FDATA("M",MEDN,551)) D REPPPD ;process the repeating fld
;
Q
;
REPPPD ; This subroutine will process the preferred product repeating fields
; that are a part of the claim segment.
; five fields here- 552 - Preferred product id qualifier
; 553 - Preferred product id
; 554 - Preferred product incentive
; 555 - preferred product copay incentive
; 556 - preferred product description
;
N CNTR,COUNT,PPIDQ,PPID,PPINC,PPCOP,PPDESC,CKREC
;
S RLCNT=0
S COUNT=$G(FDATA("M",MEDN,551)) ;preferred product count
Q:COUNT'>0
;
F CNTR=1:1:COUNT D
. S (PPIDQ,PPID,PPINC,PPCOP,PPDESC)=""
. S PPIDQ=$G(FDATA("M",MEDN,552,CNTR)) ;preferred product id qual
. S PPID=$G(FDATA("M",MEDN,553,CNTR)) ;preferred product id
. S PPINC=$G(FDATA("M",MEDN,554,CNTR)) ;preferred product incentive
. S PPCOP=$G(FDATA("M",MEDN,555,CNTR)) ;preferred product copay inc
. S PPDESC=$G(FDATA("M",MEDN,556,CNTR)) ;preferred product desc
. S CKREC=PPIDQ_PPID_PPINC_PPCOP_PPDESC ;quick chk for values
. I $D(CKREC) D
.. S $P(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,0),U)=CNTR
.. S ^ABSPR(RESPIEN,1000,INDEX,551.01,"B",CNTR,CNTR)=""
.. S RLCNT=RLCNT+1
. S:$D(PPIDQ) $P(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,1)=PPIDQ
. S:$D(PPID) $P(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,2)=PPID
. S:$D(PPINC) $P(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,3)=PPINC
. S:$D(PPCOP) $P(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,4)=PPCOP
. S:$D(PPDESC) $P(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,5)=PPDESC
;
I RLCNT>0 D
. S ^ABSPR(RESPIEN,1000,INDEX,551.01,0)="^9002313.1301A^"_RLCNT_"^"_RLCNT
;
Q
;
REPADM ; This subroutine will process the repeating additional message info
; that is a part of the status segment.
; Field 526 - Additional Message Information
;
N CNTR,COUNT,RLCNT,MSG
;
S RLCNT=0
S COUNT=$O(FDATA("M",MEDN,526,""),-1) ;Additional message count
Q:COUNT'>0
;
F CNTR=1:1:COUNT D
. S MSG=$G(FDATA("M",MEDN,526,CNTR)) ;Additional message
. I $L(MSG) D
.. S $P(^ABSPR(RESPIEN,1000,INDEX,526,CNTR,0),U)=MSG
.. S ^ABSPR(RESPIEN,1000,INDEX,526,"B",MSG,CNTR)=""
.. S RLCNT=RLCNT+1
;
I RLCNT>0 D
. S ^ABSPR(RESPIEN,1000,INDEX,526,0)="^9002313.301526A^"_RLCNT_"^"_RLCNT
;
Q
ABSPOSH6 ;IHS/SD/lwj - NCPDP 5.1 Post 5.1 response [ 09/04/2002 12:57 PM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3,9,39,42,43**;JUN 21, 2001;Build 38
+2 ;-------------------------------------------------------------
+3 ; Originally, the entire response was processed in the
+4 ; ABSPOSH5 routine - but it exceed SAC limitations on
+5 ; routine size - so the processing of some of the transaction
+6 ; level information was moved to this routine. Other portions
+7 ; were moved to the ABSPOSH7 routine.
+8 ;
+9 ; This routine is called solely from ABSPOSH5.
+10 ;
+11 ;--------------------------------------------------------------
+12 ;IHS/SD/lwj 01/22/04 Patch 9
+13 ; In January 2004, BC/BS Oklahoma and WebMD allowed responses
+14 ; to be returned that indicated multiple rejection codes, when
+15 ; in fact only a single rejection code was being returned. This
+16 ; caused problems, as we had followed the HIPAA standards that
+17 ; said that the count should match the number of rejection codes.
+18 ; While the issue was raised to WebMD that they were out of
+19 ; compliance, we still made changes to our code just in case
+20 ; they allowed others through.
+21 ; The change was originate by POC in Oklahoma.
+22 ;--------------------------------------------------------------
+23 ;
+24 QUIT
+25 ;
RESPSTS ;EP - NCPDP 5.1 response processing (moved from ABSPOSH5)
+1 ; called from WRTTRAN^ABSPOSH5
+2 ; MEDN is set in ABSPOSH5 in the WRTTRAN subroutine
+3 ; process the response status segment - here's the fields we MIGHT
+4 ; encounter:
+5 ; 112 - transaction response status (mandatory)
+6 ; 503 - authorization number
+7 ; 510 - reject count
+8 ; 511 - reject code (repeating field)
+9 ; 546 - reject field occurrence indicator (repeating field)
+10 ; 547 - approved message code count
+11 ; 548 - approved message code (repeating field)
+12 ; 526 - additional message information
+13 ; 549 - help desk phone number qualifier
+14 ; 550 - help desk phone number
+15 ;
+16 ; *special note - in 3.2 the transaction response is stored in field
+17 ; 501 at the prescription level. In 5.1 that was moved to field 112.
+18 ; All the reports are based on the 501 field, so to keep things
+19 ; simple, we will simply update both the 112 and 501 fields with
+20 ; the transaction level response status.
+21 ;
+22 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,110),U,2)=$GET(FDATA("M",MEDN,112))
+23 ;501
SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,500),U)=$GET(FDATA("M",MEDN,112))
+24 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,500),U,3)=$GET(FDATA("M",MEDN,503))
+25 ;
+26 ; process reject information if there
+27 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,500),U,10)=$GET(FDATA("M",MEDN,510))
+28 ;process the rejection codes
IF $DATA(FDATA("M",MEDN,510))
DO REPREJ
+29 ;
+30 ; process approved information if there
+31 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,540),U,7)=$GET(FDATA("M",MEDN,547))
+32 ;process the repeating fld
IF $DATA(FDATA("M",MEDN,547))
DO REPAPP
+33 ;
+34 ; finish up with the additional message, and help desk information
+35 ;IHS/OIT/CASSevern/Pieran/RAN 11-28-2011 42 making field 526 a repeating field
+36 ;S $P(^ABSPR(RESPIEN,1000,INDEX,526),U)=$G(FDATA("M",MEDN,526))
+37 ;process additional messages
IF $DATA(FDATA("M",MEDN,526))
DO REPADM
+38 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,540),U,9)=$GET(FDATA("M",MEDN,549))
+39 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,540),U,10)=$GET(FDATA("M",MEDN,550))
+40 ;
+41 ;
+42 QUIT
+43 ;
REPREJ ; This subroutine will process the reject repeating fields
+1 ; that are a part of the status segment.
+2 ; Two fields here - 511 - Reject Code and
+3 ; 546 - Reject field occurrence indicator
+4 ;
+5 NEW CNTR,COUNT,RJCD,RJOC,RLCNT
+6 ;
+7 SET RLCNT=0
+8 ;reject count
SET COUNT=$GET(FDATA("M",MEDN,510))
+9 IF COUNT'>0
QUIT
+10 ;
+11 FOR CNTR=1:1:COUNT
Begin DoDot:1
+12 SET (RJCD,RJOC)=""
+13 ;rejection code
SET RJCD=$GET(FDATA("M",MEDN,511,CNTR))
+14 ;IHS/OIT/CNI/RAN 5/21/2010 Patch 39 Strip out unwanted spaces being sent by EMDEON
+15 SET RJCD=$TRANSLATE(RJCD," ","")
+16 ;reject fld occurence ind
SET RJOC=$GET(FDATA("M",MEDN,546,CNTR))
+17 ;IHS/SD/lwj 1/22/04 patch 9 nxt line remarked out, following
+18 ; added
+19 ;I $D(RJCD) D
+20 IF $GET(RJCD)]""
Begin DoDot:2
+21 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,511,CNTR,0),U)=RJCD
+22 SET ^ABSPR(RESPIEN,1000,INDEX,511,"B",RJCD,CNTR)=""
End DoDot:2
+23 ;IHS/SD/lwj 1/22/04 patch 9 nxt two lns remkd out, nxt 2 added
+24 ;S:$D(RJOC) $P(^ABSPR(RESPIEN,1000,INDEX,511,CNTR,0),U,2)=RJOC
+25 ;S:(($D(RJOC))!($D(RJCD))) RLCNT=RLCNT+1
+26 IF $GET(RJOC)]""
SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,511,CNTR,0),U,2)=RJOC
+27 IF (($GET(RJOC)]"")!($GET(RJCD)]""))
SET RLCNT=RLCNT+1
End DoDot:1
+28 ;
+29 IF RLCNT>0
Begin DoDot:1
+30 SET ^ABSPR(RESPIEN,1000,INDEX,511,0)="^9002313.03511A^"_RLCNT_"^"_RLCNT
End DoDot:1
+31 ;
+32 QUIT
+33 ;
+34 ;
REPAPP ; This subroutine will process the approved repeating field
+1 ; that is a part of the status segment.
+2 ; Field 548 - Approved Message Code
+3 ;
+4 NEW CNTR,COUNT,RLCNT,APP
+5 ;
+6 SET RLCNT=0
+7 ;approved message code count
SET COUNT=$GET(FDATA("M",MEDN,547))
+8 IF COUNT'>0
QUIT
+9 ;
+10 FOR CNTR=1:1:COUNT
Begin DoDot:1
+11 ;approved message code
SET APP=$GET(FDATA("M",MEDN,548,CNTR))
+12 IF $LENGTH(APP)
Begin DoDot:2
+13 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,548,CNTR,0),U)=APP
+14 SET ^ABSPR(RESPIEN,1000,INDEX,548,"B",APP,CNTR)=""
+15 SET RLCNT=RLCNT+1
End DoDot:2
End DoDot:1
+16 ;
+17 IF RLCNT>0
Begin DoDot:1
+18 SET ^ABSPR(RESPIEN,1000,INDEX,548,0)="^9002313.301548A^"_RLCNT_"^"_RLCNT
End DoDot:1
+19 ;
+20 QUIT
+21 ;
RESPCLM ;EP - NCPDP 5.1 response processing (moved from ABSPOSH5)
+1 ; called from WRTTRAN^ABSPOSH5
+2 ; MEDN is set in ABSPOSH5 in the WRTTRAN subroutine
+3 ; process the response claim segment - here's the fields we MIGHT
+4 ; encounter:
+5 ; 455 - prescription/service reference number qualifier
+6 ; 402 - prescripton/service reference number
+7 ; 551 - preferred product count
+8 ; 552 - preferred product id qualifier (repeating)
+9 ; 553 - preferred product id (repeating)
+10 ; 554 - preferred product incentive (repeating)
+11 ; 555 - preferred product copay incentive (repeating)
+12 ; 556 - preferred product description (repeating)
+13 ;
+14 ; start with what are suppose to be mandatory fields
+15 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,450),U,5)=$GET(FDATA("M",MEDN,455))
+16 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,400),U,2)=$GET(FDATA("M",MEDN,402))
+17 ;
+18 ; now lets try to process the preferred product repeating fields
+19 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,550),U)=$GET(FDATA("M",MEDN,551))
+20 ;process the repeating fld
IF $DATA(FDATA("M",MEDN,551))
DO REPPPD
+21 ;
+22 QUIT
+23 ;
REPPPD ; This subroutine will process the preferred product repeating fields
+1 ; that are a part of the claim segment.
+2 ; five fields here- 552 - Preferred product id qualifier
+3 ; 553 - Preferred product id
+4 ; 554 - Preferred product incentive
+5 ; 555 - preferred product copay incentive
+6 ; 556 - preferred product description
+7 ;
+8 NEW CNTR,COUNT,PPIDQ,PPID,PPINC,PPCOP,PPDESC,CKREC
+9 ;
+10 SET RLCNT=0
+11 ;preferred product count
SET COUNT=$GET(FDATA("M",MEDN,551))
+12 IF COUNT'>0
QUIT
+13 ;
+14 FOR CNTR=1:1:COUNT
Begin DoDot:1
+15 SET (PPIDQ,PPID,PPINC,PPCOP,PPDESC)=""
+16 ;preferred product id qual
SET PPIDQ=$GET(FDATA("M",MEDN,552,CNTR))
+17 ;preferred product id
SET PPID=$GET(FDATA("M",MEDN,553,CNTR))
+18 ;preferred product incentive
SET PPINC=$GET(FDATA("M",MEDN,554,CNTR))
+19 ;preferred product copay inc
SET PPCOP=$GET(FDATA("M",MEDN,555,CNTR))
+20 ;preferred product desc
SET PPDESC=$GET(FDATA("M",MEDN,556,CNTR))
+21 ;quick chk for values
SET CKREC=PPIDQ_PPID_PPINC_PPCOP_PPDESC
+22 IF $DATA(CKREC)
Begin DoDot:2
+23 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,0),U)=CNTR
+24 SET ^ABSPR(RESPIEN,1000,INDEX,551.01,"B",CNTR,CNTR)=""
+25 SET RLCNT=RLCNT+1
End DoDot:2
+26 IF $DATA(PPIDQ)
SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,1)=PPIDQ
+27 IF $DATA(PPID)
SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,2)=PPID
+28 IF $DATA(PPINC)
SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,3)=PPINC
+29 IF $DATA(PPCOP)
SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,4)=PPCOP
+30 IF $DATA(PPDESC)
SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,5)=PPDESC
End DoDot:1
+31 ;
+32 IF RLCNT>0
Begin DoDot:1
+33 SET ^ABSPR(RESPIEN,1000,INDEX,551.01,0)="^9002313.1301A^"_RLCNT_"^"_RLCNT
End DoDot:1
+34 ;
+35 QUIT
+36 ;
REPADM ; This subroutine will process the repeating additional message info
+1 ; that is a part of the status segment.
+2 ; Field 526 - Additional Message Information
+3 ;
+4 NEW CNTR,COUNT,RLCNT,MSG
+5 ;
+6 SET RLCNT=0
+7 ;Additional message count
SET COUNT=$ORDER(FDATA("M",MEDN,526,""),-1)
+8 IF COUNT'>0
QUIT
+9 ;
+10 FOR CNTR=1:1:COUNT
Begin DoDot:1
+11 ;Additional message
SET MSG=$GET(FDATA("M",MEDN,526,CNTR))
+12 IF $LENGTH(MSG)
Begin DoDot:2
+13 SET $PIECE(^ABSPR(RESPIEN,1000,INDEX,526,CNTR,0),U)=MSG
+14 SET ^ABSPR(RESPIEN,1000,INDEX,526,"B",MSG,CNTR)=""
+15 SET RLCNT=RLCNT+1
End DoDot:2
End DoDot:1
+16 ;
+17 IF RLCNT>0
Begin DoDot:1
+18 SET ^ABSPR(RESPIEN,1000,INDEX,526,0)="^9002313.301526A^"_RLCNT_"^"_RLCNT
End DoDot:1
+19 ;
+20 QUIT
