Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPOSAE

ABSPOSAE.m

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