ABSPOSAE ; IHS/SD/lwj - send/receive E1 trans ; [ 10/07/2005 2:11 pM ]
;;1.0;PHARMACY POINT OF SALE;**14,16,17,21,28,42,47,48**;JUN 21, 2001;Build 27
;
; ABSPOSAE is the main program for send/receive communications
; with the Envoy switch for E1 transactions. It was originally
; a copy of ABSPOSAM that was modified to fit the needs of the
; E1. The largest difference is that the E1 will not be tasked -
; it will be online / real time, with an immediate response for
; the user when possible.
;
; This routine will be checking ^ABSPECX("ABSPOSQ3 to make sure
; that we aren't currently sending claims, if claims are currently
; sending, we will need wait until the line is clear.
;
; The E1 transaction is the eligibility transaction, and was
; needed when Medicare Part D was introduced in January 2006.
;
;--------------------------------------------------------------------
;IHS/SD/RLT - 3/22/06 - Fixed SAC check error.
; S12+10 - Added spaces after Q 0.
;--------------------------------------------------------------------
;IHS/SD/RLT - 5/17/06 - Patch 17
; Added lock so the regular claims processing
; doesn't clobber this process in the call to
; JOBCOUNT^ABSPOSQ3. Also made sure the lock
; wasn't left if the program errored out.
;IHS/SD/RLT - 05/24/07 - Patch 21
; E1 enhancements - ^ABSPOSE2
;
;--------------------------------------------------------------------
;IHS/OIT/SCR - 09/22/08 - Patch 28 - Modified subroutine CALLOIT
; Changed contact information from 'OIT HELP DESK'
; to 'LOCAL HELP DESK'
;--------------------------------------------------------------------
Q
SEND(E1MSG,E1IEN) ;EP - from ABSPOSE1/ABSPOSE2
;
;must have these defined for ABSPOSAR
N ACK,ENQ,EOT,ETX,NAK,STX,ETB
S ACK=$C(6),ENQ=$C(5),EOT=$C(4),ETX=$C(3)
S NAK=$C(21),STX=$C(2),ETB=$C(23)
;
N DIALOUT,TRYCNT,SENDE1,RESPMSG,RESPLRC
S DIALOUT=$$DIALOUT
S (TRYCNT,SENDE1)=0
;
; Let's make sure that claims aren't currently being
; processed - if they are, let's wait a little and
; and see if we can grab the connection.
S ^ABSPECX("ABSPOSQ3","JOB",$J)=$H
S ^ABSPECX("ABSPOSQ3","JOB",$J,"DIALOUT")=DIALOUT
N ABSPERR
S ABSPERR=0
F D Q:(SENDE1)!(TRYCNT>5)!(ABSPERR) H 2 ;OIT/CAS/RCS Patch 47, Give more time and more tries before quiting
. ;S:$$JOBCOUNT^ABSPOSQ3'>$$MAXJOBS^ABSPOSQ3 SENDE1=1
. I $$JOBCOUNT^ABSPOSQ3'>$$MAXJOBS^ABSPOSQ3 D
. . L +^ABSPECX("ABSPOSQ3","JOB",$J):0
. . I '$T D Q
. . . S ABSPERR=1
. . . D RECERR
. . . D IMPOSS^ABSPOSUE("P","TI","E1 can't obtain job-specific lock for $J="_$J_" ????",,"COMMS",$T(+0))
. . Q:ABSPERR
. . S SENDE1=1
. Q:ABSPERR
. I 'SENDE1 D
. . S TRYCNT=TRYCNT+1
. . D CLMSMSG
Q:ABSPERR
I 'SENDE1 D ERRCPRC Q
;
; now let's make sure we have all the information we need to
; make a connection and that we are not in a shutdown mode
S12 ;
;N IO S IO=$$IO^ABSPOSA(DIALOUT) I IO="" G S12:$$IMPOSS^ABSPOSUE("DB","TRI","IO field missing in DIALOUT="_DIALOUT,,"S12",$T(+0))
N IO S IO=$$IO^ABSPOSA(DIALOUT)
I IO="" D Q
. D RECERR
. D IMPOSS^ABSPOSUE("DB","TRI","IO field missing in DIALOUT="_DIALOUT,,"S12",$T(+0))
;
N T1LINE S T1LINE=$$T1DIRECT^ABSPOSA(DIALOUT)
;
I $$SHUTDOWN^ABSPOSQ3 D SHUTERR Q 0
;
; Make the connection to Envoy (aka WebMD, aka Emdeon)
S RET=$$CONNECT^ABSPOSAQ(DIALOUT)
I RET D CONNERR Q 0 ;if we can't connect, we need to quit for now
;
;
;Send message to host
D SENDREQ^ABSPOSAS(DIALOUT,.E1MSG)
;
; special note - none of the checking done in ABSPOSAM is
; done here - E1s are only set up for a T1 connection -
; no modem commands.
;
;Get the response
S HMSG=$$GETMSG^ABSPOSAR(DIALOUT,.RESPMSG,.RESPLRC,60)
;
;HMSG="ETX" or "EOT" or "" (if timed out)
;
I HMSG="ETX" D
. N DIE,DR,DA
. S DIE="^ABSPR(",DA=E1IEN,DR="9999999////RECEIVED "_$L(HMSG)_" bytes."
E D Q RET
. I HMSG'="+++" D HANGUP^ABSPOSAB(DIALOUT)
. S RET=$S(HMSG="+++":30261,HMSG="":30262,1:30263)
. D ERRRESP
;
D CLOSE^ABSPOSAB(DIALOUT) ;close the connection for other transactions
D ENDJOB99^ABSPOSQ3 ;release it so the claims can process again
;
; now let's parse the raw response, store it in ^ABSPE, and print
; it out for the user to view
D PRCRESP
;
D PRNTRESP
;
;
Q 0
;
PRCRESP ; this subroutine is responsible for facilitating the parsing of the
; raw response and storing the information in ^ABSPE. We will leave
; the displaying of the data up to ^ABSPOSE1/^ABSPOSE2.
;
N FDATA,WP,I,RREC,ZERR ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
N DIE,DR,DA
;
M RREC=RESPMSG
;
; let's go ahead and write out the raw response to ^ABSPE
F I=1:100:$L(RREC) S WP(I/100+1,0)=$E(RREC,I,I+99)
D WP^DIE(9002313.7,E1IEN_",",2000,"","WP","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
I $D(ZERR) D LOG^ABSPOSL2("PRCRESP^ABSPOSAE",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
;start here when we are ready to parse data out again
; next let's parse the data out into the actual fields
D PARSEE1^ABSPOSH4(RREC,E1IEN)
;
; now let's file the parsed data in ^ABSPE
K DIE
S DIE="^ABSPE(",DA=E1IEN
D FILEDT
D FILEMIN
D FILESTS
;
Q
;
FILEDT ;this subroutine simply gets the current date and time
; and files it in the .03 field in ^ABSPE file.
;
N %,X
D NOW^%DTC
S DR=".03////"_$G(%)_";"
;
Q
;
FILEMIN ; This subroutine will take out the data that was parsed
; out for the message and insurance segments and file it
; in the ^ABSPE file.
;
; now lets look for a message, if there was one
I $G(FDATA(102))="D0",$G(FDATA("M",1,112))'="R" D MESBLD
S:$D(FDATA(504)) DR=$G(DR)_"504////"_$TR(FDATA(504),";","#")_";"
;
; if there was any insurance information passed back - let's record it
S:$D(FDATA(301)) DR=$G(DR)_"301.01////"_FDATA(301)_";" ;group ID
S:$D(FDATA(524)) DR=$G(DR)_"524.01////"_FDATA(524)_";" ;plan ID
S:$D(FDATA(545)) DR=$G(DR)_"545////"_FDATA(545)_";" ;network reimbrsment id
S:$D(FDATA(568)) DR=$G(DR)_"568////"_FDATA(568)_";" ;payer ID qualifier
S:$D(FDATA(569)) DR=$G(DR)_"569////"_FDATA(569)_";" ;payer ID
;
Q
;
MESBLD ; Build the 504 message from the D.0 data
;
N X,Y
S Y=$E($G(FDATA("M",1,311.01)),1,13),X="LN:"_Y_$J("",13-$L(Y))
S Y=$E($G(FDATA("M",1,310.01)),1,10),X=X_"FN:"_Y_$J("",10-$L(Y))
S Y=$E($G(FDATA("M",1,304.01)),1,8),X=X_"BD:"_Y_$J("",8-$L(Y))_"PD:0"
S Y=$E($G(FDATA("M",1,340,1)),1,6),X=X_"BN:"_Y_$J("",6-$L(Y))
S Y=$E($G(FDATA("M",1,991,1)),1,10),X=X_"PN:"_Y_$J("",10-$L(Y))
S Y=$E($G(FDATA("M",1,992,1)),1,15),X=X_"GP:"_Y_$J("",15-$L(Y))
S Y=$E($G(FDATA("M",1,356,1)),1,20),X=X_"ID:"_Y_$J("",20-$L(Y))
S Y=$E($G(FDATA("M",1,142,1)),1,3),X=X_"PC:"_Y_$J("",3-$L(Y))
S Y=$E($G(FDATA("M",1,127,1)),1,10),X=X_"PH:"_Y_$J("",10-$L(Y))
S Y=$E($G(FDATA("M",1,240)),1,6),X=X_"CD:"_Y_$J("",6-$L(Y))
S Y=$E($G(FDATA("M",1,757)),1,3),X=X_"PB:"_Y_$J("",3-$L(Y))
S Y=$E($G(FDATA("M",1,144,1)),1,8),X=X_"ED:"_Y_$J("",8-$L(Y))
S Y=$E($G(FDATA("M",1,145,1)),1,8),X=X_"TD:"_Y_$J("",8-$L(Y))
S Y=$G(FDATA("M",1,138)),X=X_"LC:"_Y_$J("",1-$L(Y))
S Y=$E($G(FDATA("M",1,926)),1,8),X=X_"FI:"_Y_$J("",8-$L(Y))
S Y=$E($G(FDATA("M",1,140)),1,8),X=X_"FE:"_Y_$J("",8-$L(Y))
S Y=$E($G(FDATA("M",1,141)),1,8),X=X_"FT:"_Y_$J("",8-$L(Y))
S FDATA(504)=X
Q
;
FILESTS ;EP - NCPDP 5.1, D.0 response processing
; basic logic borrowed from ABSPOSH6
; 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
;
N MEDN
S MEDN=1 ;E1 will only have 1 transaction returned
S:$D(FDATA("M",MEDN,112)) DR=$G(DR)_"112////"_$G(FDATA("M",MEDN,112))_";"
S:$D(FDATA("M",MEDN,503)) DR=$G(DR)_"503////"_$G(FDATA("M",MEDN,503))_";"
;
; process reject and approved information if there is any
S:$D(FDATA("M",MEDN,510)) DR=$G(DR)_"510////"_$G(FDATA("M",MEDN,510))_";"
S:$D(FDATA("M",MEDN,547)) DR=$G(DR)_"547////"_$G(FDATA("M",MEDN,547))_";"
;
;last of the "normal fields" - additional and help desk information
I $G(FDATA(102))="D0",$G(FDATA("M",1,112))'="R" D ADDBLD
S:$D(FDATA("M",MEDN,526)) DR=$G(DR)_"526////"_$TR($G(FDATA("M",MEDN,526)),";","#")_";"
S:$D(FDATA("M",MEDN,549)) DR=$G(DR)_"549////"_$G(FDATA("M",MEDN,549))_";"
S:$D(FDATA("M",MEDN,550)) DR=$G(DR)_"550////"_$G(FDATA("M",MEDN,550))
;
D ^DIE
;
;now for the subfiles
K DIE,DA
D:$D(FDATA("M",MEDN,510)) REPREJ ;process the rej code multiple
D:$D(FDATA("M",MEDN,547)) REPAPP ;process the apprvd msg multiple
;
;
;
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,RJOC
N DIC,DA,DIE,DR,X,DLAYGO
;
S COUNT=$G(FDATA("M",MEDN,510)) ;reject count
Q:COUNT'>0
;
;set up our DIC variables for adding the multi header & entries
S DIC="^ABSPE("_E1IEN_","_"511,"
S DA(1)=E1IEN
S DIC("P")=$P($G(^DD(9002313.7,511,0)),"^",2)
S DIC(0)="L"
S DLAYGO=9002313
S X=0
;
;now we can add the individual entries
;
F CNTR=1:1:COUNT D
. S (X,RJOC)=""
. S X=$G(FDATA("M",MEDN,511,CNTR)) ;rejection code
. S RJOC=$G(FDATA("M",MEDN,546,CNTR)) ;reject fld occurence ind
. I $G(X)]"" D
.. D ^DIC ;add the entry
.. I $G(RJOC)]"" D ;if there is an occurence
... N DIE,DR,DA ;we'll need to update the record
... S DIE=DIC ;with the information
... S DA(1)=E1IEN,DA=+Y
... S DR="546////"_RJOC
... D ^DIE
;
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,APP
N DIC,DA,DIE,DR,X
;
S COUNT=$G(FDATA("M",MEDN,547)) ;approved message code count
Q:COUNT'>0
;
;
;because this is a multiple, we need to add the top level first
S DIC="^ABSPE("_E1IEN_","_"548,"
S DA(1)=E1IEN
S DIC("P")=$P($G(^DD(9002313.7,548,0)),"^",2)
S DIC(0)="L"
S X=0
;
;now we can add the individual entries
;
F CNTR=1:1:COUNT D
. S X=""
. S X=$G(FDATA("M",MEDN,548,CNTR)) ;approved message code
. D:$D(X) ^DIC
;
Q
;
ADDBLD ;Build Field 526 - Additional message from D.0 fields
N X,Y,I,LVL
S X=""
F I=2,3 D
. S LVL=I-1 I '$D(FDATA("M",1,340,I)) S LVL=" "
. S X=X_"OH:"_LVL
. S Y=$E($G(FDATA("M",1,340,I)),1,6),X=X_"BN:"_Y_$J("",6-$L(Y))
. S Y=$E($G(FDATA("M",1,991,I)),1,10),X=X_"PN:"_Y_$J("",10-$L(Y))
. S Y=$E($G(FDATA("M",1,992,I)),1,15),X=X_"GP:"_Y_$J("",15-$L(Y))
. S Y=$E($G(FDATA("M",1,356,I)),1,20),X=X_"ID:"_Y_$J("",20-$L(Y))
. S Y=$E($G(FDATA("M",1,142,I)),1,3),X=X_"PC:"_Y_$J("",3-$L(Y))
. S Y=$G(FDATA("M",1,143,I)),X=X_"RC:"_Y_$J("",1-$L(Y))
. S Y=$E($G(FDATA("M",1,127,I)),1,10),X=X_"PH:"_Y_$J("",10-$L(Y))
S FDATA("M",MEDN,526)=X
;
Q
;
PRNTRESP ; let's print the response for them to see
;
; right here we need to prompt for the device
;
Q:'$$DEVICE^ABSPOS6D
U IO
;D DISPLAY^ABSPOSE1(E1IEN)
D DISPLAY^ABSPOSE2(E1IEN)
D BYE^ABSPOSU5
;
Q
;
DIALOUT() ; determine where we are connecting to
; Return a pointer to File 9002313.55, the DIAL OUT file.
; get the default dial-out, otherwise
S X=$P($G(^ABSP(9002313.99,1,"DIAL-OUT DEFAULT")),U)
I 'X S X=$O(^ABSP(9002313.55,"B","DEFAULT",0))
I 'X S X=$O(^ABSP(9002313.55,0)) ; they deleted the DEFAULT one??
Q X
CLMSMSG ; let the user know that we are processing - please stand by
;
U 0
W !!!,"Waiting to make a connection - please stand by."
H 5
Q
;
SHUTERR ; user requested that the comm line be shut down - can't
; process right now
;
N WP
S WP="COMM line is shut down ????? Can't sent E1."
D RECERR
;
U 0
W !!,"*****************************************************",!
W "* COMM line is shut down- UNABLE to send *",!
W "* the eligibility check at this time. *",!
D CALLOIT
;
Q
CONNERR ; can't connect - let user know and ask them to try again
; later
;
N WP
S WP="ABSPECX(ABSPOSQ3 is currently running - can't send E1."
D RECERR
;
U 0
W !!,"*****************************************************",!
W "* UNABLE to send *",!
W "* the eligibility check at this time. *",!
D CALLOIT
;
Q
ERRCPRC ; can't send just now - claims are processing - ask user to
; try again later
;
N WP
S WP="ABSPECX(ABSPOSQ3 is currently running - can't send E1."
D RECERR
;
U 0
W !!,"*****************************************************",!
W "* Claims are currently being sent - connection **",!
W "* required for eligibility check is unavailable. *",!
D CALLOIT
;
Q
ERRRESP ; we didn't get a good response - let user now, log it in the
; raw message in ^ABSPE
;
N WP
S WP="ERROR in receiving message - RET is: "_RET
D RECERR
;
U 0
W !!,"*****************************************************",!
W "* Response was corrupt, or did not come back. *",!
D CALLOIT
;
Q
CALLOIT ; this is standard for all messages when we are communicating
; with the user
;
W "* *",!
W "* Please wait a few minutes and try again. *",!
W "* *",!
;IHS/OIT/SCR 09/23/08 patch 28 - BEGIN changed support info
;W "* If the problem persist, please contact the *",!
W "* If the problem persist, please contact *",!
W "* your local helpdesk. *",!
;IHS/OIT/SCR 09/23/08 patch 28 - END changed support info
W "*****************************************************",!!
H 5
;
Q
;
RECERR ; this will record that the response was not received in the 9999999
; field in the ^ABSPE file
;
N DIE,DA,DR,ZERR ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
;
D WP^DIE(9002313.7,E1IEN_",",2000,"","WP","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
I $D(ZERR) D LOG^ABSPOSL2("RECERR^ABSPOSAE",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
S DA=E1IEN
S DIE="^ABSPE("
S DR="9999999////ERROR" ;RESPSTS field
D ^DIE
;
D CLOSE^ABSPOSAB(DIALOUT) ;close the connection for other transactions
D ENDJOB99^ABSPOSQ3 ;kill entry in ^ABSPECX("ABSPOSQ3"
;
Q
ABSPOSAE ; IHS/SD/lwj - send/receive E1 trans ; [ 10/07/2005 2:11 pM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**14,16,17,21,28,42,47,48**;JUN 21, 2001;Build 27
+2 ;
+3 ; ABSPOSAE is the main program for send/receive communications
+4 ; with the Envoy switch for E1 transactions. It was originally
+5 ; a copy of ABSPOSAM that was modified to fit the needs of the
+6 ; E1. The largest difference is that the E1 will not be tasked -
+7 ; it will be online / real time, with an immediate response for
+8 ; the user when possible.
+9 ;
+10 ; This routine will be checking ^ABSPECX("ABSPOSQ3 to make sure
+11 ; that we aren't currently sending claims, if claims are currently
+12 ; sending, we will need wait until the line is clear.
+13 ;
+14 ; The E1 transaction is the eligibility transaction, and was
+15 ; needed when Medicare Part D was introduced in January 2006.
+16 ;
+17 ;--------------------------------------------------------------------
+18 ;IHS/SD/RLT - 3/22/06 - Fixed SAC check error.
+19 ; S12+10 - Added spaces after Q 0.
+20 ;--------------------------------------------------------------------
+21 ;IHS/SD/RLT - 5/17/06 - Patch 17
+22 ; Added lock so the regular claims processing
+23 ; doesn't clobber this process in the call to
+24 ; JOBCOUNT^ABSPOSQ3. Also made sure the lock
+25 ; wasn't left if the program errored out.
+26 ;IHS/SD/RLT - 05/24/07 - Patch 21
+27 ; E1 enhancements - ^ABSPOSE2
+28 ;
+29 ;--------------------------------------------------------------------
+30 ;IHS/OIT/SCR - 09/22/08 - Patch 28 - Modified subroutine CALLOIT
+31 ; Changed contact information from 'OIT HELP DESK'
+32 ; to 'LOCAL HELP DESK'
+33 ;--------------------------------------------------------------------
+34 QUIT
SEND(E1MSG,E1IEN) ;EP - from ABSPOSE1/ABSPOSE2
+1 ;
+2 ;must have these defined for ABSPOSAR
+3 NEW ACK,ENQ,EOT,ETX,NAK,STX,ETB
+4 SET ACK=$CHAR(6)
SET ENQ=$CHAR(5)
SET EOT=$CHAR(4)
SET ETX=$CHAR(3)
+5 SET NAK=$CHAR(21)
SET STX=$CHAR(2)
SET ETB=$CHAR(23)
+6 ;
+7 NEW DIALOUT,TRYCNT,SENDE1,RESPMSG,RESPLRC
+8 SET DIALOUT=$$DIALOUT
+9 SET (TRYCNT,SENDE1)=0
+10 ;
+11 ; Let's make sure that claims aren't currently being
+12 ; processed - if they are, let's wait a little and
+13 ; and see if we can grab the connection.
+14 SET ^ABSPECX("ABSPOSQ3","JOB",$JOB)=$HOROLOG
+15 SET ^ABSPECX("ABSPOSQ3","JOB",$JOB,"DIALOUT")=DIALOUT
+16 NEW ABSPERR
+17 SET ABSPERR=0
+18 ;OIT/CAS/RCS Patch 47, Give more time and more tries before quiting
FOR
Begin DoDot:1
+19 ;S:$$JOBCOUNT^ABSPOSQ3'>$$MAXJOBS^ABSPOSQ3 SENDE1=1
+20 IF $$JOBCOUNT^ABSPOSQ3'>$$MAXJOBS^ABSPOSQ3
Begin DoDot:2
+21 LOCK +^ABSPECX("ABSPOSQ3","JOB",$JOB):0
+22 IF '$TEST
Begin DoDot:3
+23 SET ABSPERR=1
+24 DO RECERR
+25 DO IMPOSS^ABSPOSUE("P","TI","E1 can't obtain job-specific lock for $J="_$JOB_" ????",,"COMMS",$TEXT(+0))
End DoDot:3
QUIT
+26 IF ABSPERR
QUIT
+27 SET SENDE1=1
End DoDot:2
+28 IF ABSPERR
QUIT
+29 IF 'SENDE1
Begin DoDot:2
+30 SET TRYCNT=TRYCNT+1
+31 DO CLMSMSG
End DoDot:2
End DoDot:1
IF (SENDE1)!(TRYCNT>5)!(ABSPERR)
QUIT
HANG 2
+32 IF ABSPERR
QUIT
+33 IF 'SENDE1
DO ERRCPRC
QUIT
+34 ;
+35 ; now let's make sure we have all the information we need to
+36 ; make a connection and that we are not in a shutdown mode
S12 ;
+1 ;N IO S IO=$$IO^ABSPOSA(DIALOUT) I IO="" G S12:$$IMPOSS^ABSPOSUE("DB","TRI","IO field missing in DIALOUT="_DIALOUT,,"S12",$T(+0))
+2 NEW IO
SET IO=$$IO^ABSPOSA(DIALOUT)
+3 IF IO=""
Begin DoDot:1
+4 DO RECERR
+5 DO IMPOSS^ABSPOSUE("DB","TRI","IO field missing in DIALOUT="_DIALOUT,,"S12",$TEXT(+0))
End DoDot:1
QUIT
+6 ;
+7 NEW T1LINE
SET T1LINE=$$T1DIRECT^ABSPOSA(DIALOUT)
+8 ;
+9 IF $$SHUTDOWN^ABSPOSQ3
DO SHUTERR
QUIT 0
+10 ;
+11 ; Make the connection to Envoy (aka WebMD, aka Emdeon)
+12 SET RET=$$CONNECT^ABSPOSAQ(DIALOUT)
+13 ;if we can't connect, we need to quit for now
IF RET
DO CONNERR
QUIT 0
+14 ;
+15 ;
+16 ;Send message to host
+17 DO SENDREQ^ABSPOSAS(DIALOUT,.E1MSG)
+18 ;
+19 ; special note - none of the checking done in ABSPOSAM is
+20 ; done here - E1s are only set up for a T1 connection -
+21 ; no modem commands.
+22 ;
+23 ;Get the response
+24 SET HMSG=$$GETMSG^ABSPOSAR(DIALOUT,.RESPMSG,.RESPLRC,60)
+25 ;
+26 ;HMSG="ETX" or "EOT" or "" (if timed out)
+27 ;
+28 IF HMSG="ETX"
Begin DoDot:1
+29 NEW DIE,DR,DA
+30 SET DIE="^ABSPR("
SET DA=E1IEN
SET DR="9999999////RECEIVED "_$LENGTH(HMSG)_" bytes."
End DoDot:1
+31 IF '$TEST
Begin DoDot:1
+32 IF HMSG'="+++"
DO HANGUP^ABSPOSAB(DIALOUT)
+33 SET RET=$SELECT(HMSG="+++":30261,HMSG="":30262,1:30263)
+34 DO ERRRESP
End DoDot:1
QUIT RET
+35 ;
+36 ;close the connection for other transactions
DO CLOSE^ABSPOSAB(DIALOUT)
+37 ;release it so the claims can process again
DO ENDJOB99^ABSPOSQ3
+38 ;
+39 ; now let's parse the raw response, store it in ^ABSPE, and print
+40 ; it out for the user to view
+41 DO PRCRESP
+42 ;
+43 DO PRNTRESP
+44 ;
+45 ;
+46 QUIT 0
+47 ;
PRCRESP ; this subroutine is responsible for facilitating the parsing of the
+1 ; raw response and storing the information in ^ABSPE. We will leave
+2 ; the displaying of the data up to ^ABSPOSE1/^ABSPOSE2.
+3 ;
+4 ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
NEW FDATA,WP,I,RREC,ZERR
+5 NEW DIE,DR,DA
+6 ;
+7 MERGE RREC=RESPMSG
+8 ;
+9 ; let's go ahead and write out the raw response to ^ABSPE
+10 FOR I=1:100:$LENGTH(RREC)
SET WP(I/100+1,0)=$EXTRACT(RREC,I,I+99)
+11 ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
DO WP^DIE(9002313.7,E1IEN_",",2000,"","WP","ZERR")
+12 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(ZERR)
DO LOG^ABSPOSL2("PRCRESP^ABSPOSAE",.ZERR)
+13 ;
+14 ;start here when we are ready to parse data out again
+15 ; next let's parse the data out into the actual fields
+16 DO PARSEE1^ABSPOSH4(RREC,E1IEN)
+17 ;
+18 ; now let's file the parsed data in ^ABSPE
+19 KILL DIE
+20 SET DIE="^ABSPE("
SET DA=E1IEN
+21 DO FILEDT
+22 DO FILEMIN
+23 DO FILESTS
+24 ;
+25 QUIT
+26 ;
FILEDT ;this subroutine simply gets the current date and time
+1 ; and files it in the .03 field in ^ABSPE file.
+2 ;
+3 NEW %,X
+4 DO NOW^%DTC
+5 SET DR=".03////"_$GET(%)_";"
+6 ;
+7 QUIT
+8 ;
FILEMIN ; This subroutine will take out the data that was parsed
+1 ; out for the message and insurance segments and file it
+2 ; in the ^ABSPE file.
+3 ;
+4 ; now lets look for a message, if there was one
+5 IF $GET(FDATA(102))="D0"
IF $GET(FDATA("M",1,112))'="R"
DO MESBLD
+6 IF $DATA(FDATA(504))
SET DR=$GET(DR)_"504////"_$TRANSLATE(FDATA(504),";","#")_";"
+7 ;
+8 ; if there was any insurance information passed back - let's record it
+9 ;group ID
IF $DATA(FDATA(301))
SET DR=$GET(DR)_"301.01////"_FDATA(301)_";"
+10 ;plan ID
IF $DATA(FDATA(524))
SET DR=$GET(DR)_"524.01////"_FDATA(524)_";"
+11 ;network reimbrsment id
IF $DATA(FDATA(545))
SET DR=$GET(DR)_"545////"_FDATA(545)_";"
+12 ;payer ID qualifier
IF $DATA(FDATA(568))
SET DR=$GET(DR)_"568////"_FDATA(568)_";"
+13 ;payer ID
IF $DATA(FDATA(569))
SET DR=$GET(DR)_"569////"_FDATA(569)_";"
+14 ;
+15 QUIT
+16 ;
MESBLD ; Build the 504 message from the D.0 data
+1 ;
+2 NEW X,Y
+3 SET Y=$EXTRACT($GET(FDATA("M",1,311.01)),1,13)
SET X="LN:"_Y_$JUSTIFY("",13-$LENGTH(Y))
+4 SET Y=$EXTRACT($GET(FDATA("M",1,310.01)),1,10)
SET X=X_"FN:"_Y_$JUSTIFY("",10-$LENGTH(Y))
+5 SET Y=$EXTRACT($GET(FDATA("M",1,304.01)),1,8)
SET X=X_"BD:"_Y_$JUSTIFY("",8-$LENGTH(Y))_"PD:0"
+6 SET Y=$EXTRACT($GET(FDATA("M",1,340,1)),1,6)
SET X=X_"BN:"_Y_$JUSTIFY("",6-$LENGTH(Y))
+7 SET Y=$EXTRACT($GET(FDATA("M",1,991,1)),1,10)
SET X=X_"PN:"_Y_$JUSTIFY("",10-$LENGTH(Y))
+8 SET Y=$EXTRACT($GET(FDATA("M",1,992,1)),1,15)
SET X=X_"GP:"_Y_$JUSTIFY("",15-$LENGTH(Y))
+9 SET Y=$EXTRACT($GET(FDATA("M",1,356,1)),1,20)
SET X=X_"ID:"_Y_$JUSTIFY("",20-$LENGTH(Y))
+10 SET Y=$EXTRACT($GET(FDATA("M",1,142,1)),1,3)
SET X=X_"PC:"_Y_$JUSTIFY("",3-$LENGTH(Y))
+11 SET Y=$EXTRACT($GET(FDATA("M",1,127,1)),1,10)
SET X=X_"PH:"_Y_$JUSTIFY("",10-$LENGTH(Y))
+12 SET Y=$EXTRACT($GET(FDATA("M",1,240)),1,6)
SET X=X_"CD:"_Y_$JUSTIFY("",6-$LENGTH(Y))
+13 SET Y=$EXTRACT($GET(FDATA("M",1,757)),1,3)
SET X=X_"PB:"_Y_$JUSTIFY("",3-$LENGTH(Y))
+14 SET Y=$EXTRACT($GET(FDATA("M",1,144,1)),1,8)
SET X=X_"ED:"_Y_$JUSTIFY("",8-$LENGTH(Y))
+15 SET Y=$EXTRACT($GET(FDATA("M",1,145,1)),1,8)
SET X=X_"TD:"_Y_$JUSTIFY("",8-$LENGTH(Y))
+16 SET Y=$GET(FDATA("M",1,138))
SET X=X_"LC:"_Y_$JUSTIFY("",1-$LENGTH(Y))
+17 SET Y=$EXTRACT($GET(FDATA("M",1,926)),1,8)
SET X=X_"FI:"_Y_$JUSTIFY("",8-$LENGTH(Y))
+18 SET Y=$EXTRACT($GET(FDATA("M",1,140)),1,8)
SET X=X_"FE:"_Y_$JUSTIFY("",8-$LENGTH(Y))
+19 SET Y=$EXTRACT($GET(FDATA("M",1,141)),1,8)
SET X=X_"FT:"_Y_$JUSTIFY("",8-$LENGTH(Y))
+20 SET FDATA(504)=X
+21 QUIT
+22 ;
FILESTS ;EP - NCPDP 5.1, D.0 response processing
+1 ; basic logic borrowed from ABSPOSH6
+2 ; process the response status segment - here's the fields we MIGHT
+3 ; encounter:
+4 ; 112 - transaction response status (mandatory)
+5 ; 503 - authorization number
+6 ; 510 - reject count
+7 ; 511 - reject code (repeating field)
+8 ; 546 - reject field occurrence indicator (repeating field)
+9 ; 547 - approved message code count
+10 ; 548 - approved message code (repeating field)
+11 ; 526 - additional message information
+12 ; 549 - help desk phone number qualifier
+13 ; 550 - help desk phone number
+14 ;
+15 NEW MEDN
+16 ;E1 will only have 1 transaction returned
SET MEDN=1
+17 IF $DATA(FDATA("M",MEDN,112))
SET DR=$GET(DR)_"112////"_$GET(FDATA("M",MEDN,112))_";"
+18 IF $DATA(FDATA("M",MEDN,503))
SET DR=$GET(DR)_"503////"_$GET(FDATA("M",MEDN,503))_";"
+19 ;
+20 ; process reject and approved information if there is any
+21 IF $DATA(FDATA("M",MEDN,510))
SET DR=$GET(DR)_"510////"_$GET(FDATA("M",MEDN,510))_";"
+22 IF $DATA(FDATA("M",MEDN,547))
SET DR=$GET(DR)_"547////"_$GET(FDATA("M",MEDN,547))_";"
+23 ;
+24 ;last of the "normal fields" - additional and help desk information
+25 IF $GET(FDATA(102))="D0"
IF $GET(FDATA("M",1,112))'="R"
DO ADDBLD
+26 IF $DATA(FDATA("M",MEDN,526))
SET DR=$GET(DR)_"526////"_$TRANSLATE($GET(FDATA("M",MEDN,526)),";","#")_";"
+27 IF $DATA(FDATA("M",MEDN,549))
SET DR=$GET(DR)_"549////"_$GET(FDATA("M",MEDN,549))_";"
+28 IF $DATA(FDATA("M",MEDN,550))
SET DR=$GET(DR)_"550////"_$GET(FDATA("M",MEDN,550))
+29 ;
+30 DO ^DIE
+31 ;
+32 ;now for the subfiles
+33 KILL DIE,DA
+34 ;process the rej code multiple
IF $DATA(FDATA("M",MEDN,510))
DO REPREJ
+35 ;process the apprvd msg multiple
IF $DATA(FDATA("M",MEDN,547))
DO REPAPP
+36 ;
+37 ;
+38 ;
+39 QUIT
+40 ;
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,RJOC
+6 NEW DIC,DA,DIE,DR,X,DLAYGO
+7 ;
+8 ;reject count
SET COUNT=$GET(FDATA("M",MEDN,510))
+9 IF COUNT'>0
QUIT
+10 ;
+11 ;set up our DIC variables for adding the multi header & entries
+12 SET DIC="^ABSPE("_E1IEN_","_"511,"
+13 SET DA(1)=E1IEN
+14 SET DIC("P")=$PIECE($GET(^DD(9002313.7,511,0)),"^",2)
+15 SET DIC(0)="L"
+16 SET DLAYGO=9002313
+17 SET X=0
+18 ;
+19 ;now we can add the individual entries
+20 ;
+21 FOR CNTR=1:1:COUNT
Begin DoDot:1
+22 SET (X,RJOC)=""
+23 ;rejection code
SET X=$GET(FDATA("M",MEDN,511,CNTR))
+24 ;reject fld occurence ind
SET RJOC=$GET(FDATA("M",MEDN,546,CNTR))
+25 IF $GET(X)]""
Begin DoDot:2
+26 ;add the entry
DO ^DIC
+27 ;if there is an occurence
IF $GET(RJOC)]""
Begin DoDot:3
+28 ;we'll need to update the record
NEW DIE,DR,DA
+29 ;with the information
SET DIE=DIC
+30 SET DA(1)=E1IEN
SET DA=+Y
+31 SET DR="546////"_RJOC
+32 DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 QUIT
+35 ;
+36 ;
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,APP
+5 NEW DIC,DA,DIE,DR,X
+6 ;
+7 ;approved message code count
SET COUNT=$GET(FDATA("M",MEDN,547))
+8 IF COUNT'>0
QUIT
+9 ;
+10 ;
+11 ;because this is a multiple, we need to add the top level first
+12 SET DIC="^ABSPE("_E1IEN_","_"548,"
+13 SET DA(1)=E1IEN
+14 SET DIC("P")=$PIECE($GET(^DD(9002313.7,548,0)),"^",2)
+15 SET DIC(0)="L"
+16 SET X=0
+17 ;
+18 ;now we can add the individual entries
+19 ;
+20 FOR CNTR=1:1:COUNT
Begin DoDot:1
+21 SET X=""
+22 ;approved message code
SET X=$GET(FDATA("M",MEDN,548,CNTR))
+23 IF $DATA(X)
DO ^DIC
End DoDot:1
+24 ;
+25 QUIT
+26 ;
ADDBLD ;Build Field 526 - Additional message from D.0 fields
+1 NEW X,Y,I,LVL
+2 SET X=""
+3 FOR I=2,3
Begin DoDot:1
+4 SET LVL=I-1
IF '$DATA(FDATA("M",1,340,I))
SET LVL=" "
+5 SET X=X_"OH:"_LVL
+6 SET Y=$EXTRACT($GET(FDATA("M",1,340,I)),1,6)
SET X=X_"BN:"_Y_$JUSTIFY("",6-$LENGTH(Y))
+7 SET Y=$EXTRACT($GET(FDATA("M",1,991,I)),1,10)
SET X=X_"PN:"_Y_$JUSTIFY("",10-$LENGTH(Y))
+8 SET Y=$EXTRACT($GET(FDATA("M",1,992,I)),1,15)
SET X=X_"GP:"_Y_$JUSTIFY("",15-$LENGTH(Y))
+9 SET Y=$EXTRACT($GET(FDATA("M",1,356,I)),1,20)
SET X=X_"ID:"_Y_$JUSTIFY("",20-$LENGTH(Y))
+10 SET Y=$EXTRACT($GET(FDATA("M",1,142,I)),1,3)
SET X=X_"PC:"_Y_$JUSTIFY("",3-$LENGTH(Y))
+11 SET Y=$GET(FDATA("M",1,143,I))
SET X=X_"RC:"_Y_$JUSTIFY("",1-$LENGTH(Y))
+12 SET Y=$EXTRACT($GET(FDATA("M",1,127,I)),1,10)
SET X=X_"PH:"_Y_$JUSTIFY("",10-$LENGTH(Y))
End DoDot:1
+13 SET FDATA("M",MEDN,526)=X
+14 ;
+15 QUIT
+16 ;
PRNTRESP ; let's print the response for them to see
+1 ;
+2 ; right here we need to prompt for the device
+3 ;
+4 IF '$$DEVICE^ABSPOS6D
QUIT
+5 USE IO
+6 ;D DISPLAY^ABSPOSE1(E1IEN)
+7 DO DISPLAY^ABSPOSE2(E1IEN)
+8 DO BYE^ABSPOSU5
+9 ;
+10 QUIT
+11 ;
DIALOUT() ; determine where we are connecting to
+1 ; Return a pointer to File 9002313.55, the DIAL OUT file.
+2 ; get the default dial-out, otherwise
+3 SET X=$PIECE($GET(^ABSP(9002313.99,1,"DIAL-OUT DEFAULT")),U)
+4 IF 'X
SET X=$ORDER(^ABSP(9002313.55,"B","DEFAULT",0))
+5 ; they deleted the DEFAULT one??
IF 'X
SET X=$ORDER(^ABSP(9002313.55,0))
+6 QUIT X
CLMSMSG ; let the user know that we are processing - please stand by
+1 ;
+2 USE 0
+3 WRITE !!!,"Waiting to make a connection - please stand by."
+4 HANG 5
+5 QUIT
+6 ;
SHUTERR ; user requested that the comm line be shut down - can't
+1 ; process right now
+2 ;
+3 NEW WP
+4 SET WP="COMM line is shut down ????? Can't sent E1."
+5 DO RECERR
+6 ;
+7 USE 0
+8 WRITE !!,"*****************************************************",!
+9 WRITE "* COMM line is shut down- UNABLE to send *",!
+10 WRITE "* the eligibility check at this time. *",!
+11 DO CALLOIT
+12 ;
+13 QUIT
CONNERR ; can't connect - let user know and ask them to try again
+1 ; later
+2 ;
+3 NEW WP
+4 SET WP="ABSPECX(ABSPOSQ3 is currently running - can't send E1."
+5 DO RECERR
+6 ;
+7 USE 0
+8 WRITE !!,"*****************************************************",!
+9 WRITE "* UNABLE to send *",!
+10 WRITE "* the eligibility check at this time. *",!
+11 DO CALLOIT
+12 ;
+13 QUIT
ERRCPRC ; can't send just now - claims are processing - ask user to
+1 ; try again later
+2 ;
+3 NEW WP
+4 SET WP="ABSPECX(ABSPOSQ3 is currently running - can't send E1."
+5 DO RECERR
+6 ;
+7 USE 0
+8 WRITE !!,"*****************************************************",!
+9 WRITE "* Claims are currently being sent - connection **",!
+10 WRITE "* required for eligibility check is unavailable. *",!
+11 DO CALLOIT
+12 ;
+13 QUIT
ERRRESP ; we didn't get a good response - let user now, log it in the
+1 ; raw message in ^ABSPE
+2 ;
+3 NEW WP
+4 SET WP="ERROR in receiving message - RET is: "_RET
+5 DO RECERR
+6 ;
+7 USE 0
+8 WRITE !!,"*****************************************************",!
+9 WRITE "* Response was corrupt, or did not come back. *",!
+10 DO CALLOIT
+11 ;
+12 QUIT
CALLOIT ; this is standard for all messages when we are communicating
+1 ; with the user
+2 ;
+3 WRITE "* *",!
+4 WRITE "* Please wait a few minutes and try again. *",!
+5 WRITE "* *",!
+6 ;IHS/OIT/SCR 09/23/08 patch 28 - BEGIN changed support info
+7 ;W "* If the problem persist, please contact the *",!
+8 WRITE "* If the problem persist, please contact *",!
+9 WRITE "* your local helpdesk. *",!
+10 ;IHS/OIT/SCR 09/23/08 patch 28 - END changed support info
+11 WRITE "*****************************************************",!!
+12 HANG 5
+13 ;
+14 QUIT
+15 ;
RECERR ; this will record that the response was not received in the 9999999
+1 ; field in the ^ABSPE file
+2 ;
+3 ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
NEW DIE,DA,DR,ZERR
+4 ;
+5 ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
DO WP^DIE(9002313.7,E1IEN_",",2000,"","WP","ZERR")
+6 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(ZERR)
DO LOG^ABSPOSL2("RECERR^ABSPOSAE",.ZERR)
+7 ;
+8 SET DA=E1IEN
+9 SET DIE="^ABSPE("
+10 ;RESPSTS field
SET DR="9999999////ERROR"
+11 DO ^DIE
+12 ;
+13 ;close the connection for other transactions
DO CLOSE^ABSPOSAB(DIALOUT)
+14 ;kill entry in ^ABSPECX("ABSPOSQ3"
DO ENDJOB99^ABSPOSQ3
+15 ;
+16 QUIT
