ABSPOSE1 ; IHS/SD/lwj - E1 gereration routine ; [ 10/24/2005 10:09:07 AM ]
;;1.0;PHARMACY POINT OF SALE;**14,15,16,48**;JUN 21, 2001;Build 38
;
;IHS/SD/lwj 10/24/05 Medicare Part D E1 Transmission routine
; This routine will:
; * prompt the user for which patient an E1 should be generated for
; * determine if there are multiple pharmacies and prompt for one
; * determine if a previous E1 was sent - if so, it will prompt if
; the user would like to create a new E1
; * create the shell of the ^ABSPE entry
; * generate the E1 transmission
; * call ^ABSPOSAE to send the E1 and process the response
; * prompt for another patient
;
; 11/15/05 WE WERE ONLY ABLE TO TEST WITH NDC TROOP FACILITATION -
; ADJUSTMENTS WILL BE NEEDED WHEN WE KNOW MORE AND ARE READY TO
; GO LIVE.
;
; IHS/SD/RLT - 1/13/06 - Patch 15
; Pam Swchweitzer requested the program to end when a blank
; patient is entered.
;
; IHS/SD/RLT - 2/3/06 - Patch 16
; Fixed display error for fields 504 and 526.
;
; Fixed elig file write and lookup. Changed X from name to `IEN so
; fileman is not confused on names that bring up muliple records.
;
Q
MAIN ;EP
N POP
S POP=0
;
F D PROCESS Q:POP
;
Q
PROCESS ;
N E1PNAM,E1PIEN,E1PINFO,E1PHARM,E1IEN
;
S POP=1
; prompt for the patient
S E1PINFO=$$GETPAT
Q:E1PINFO<1
S E1PIEN=$P(E1PINFO,U) ;VA(200 patient IEN
S E1PNAM=$P(E1PINFO,U,2) ;VA(200 patient name
;
; determine the pharmacy to send on behalf of
S E1PHARM=$$GETPHARM ;E1PHARM - ien into ABSP(9002313.56
Q:E1PHARM<1
;
; establish the ^ABSPE record to work with
S E1IEN=$$GETABSPE ;E1IEN - ien into ^ABSPE
Q:E1IEN<1 ;must have had a prev one and didn't want a new one
;
;create the transmission
D CRTE1
U $P W !!,"Transmitting eligibility check, please stand by.....",!!
D SEND^ABSPOSAE(TDATA,E1IEN) ;send the transaction
S POP=0
;
;
;
Q
GETPAT() ;Prompt the user for which patient they would like to generate an E1 for
;
N ABSPDUZ2,PATDONE,Y,DIC
N X ;RLT - Patch 15
S X="" ;RLT - Patch 15
;
S PATDONE=0 ;set to one when we are done prompting
S Y=0
S ABSPDUZ2=+$G(DUZ(2)),DUZ(2)=0
;
U $P W !!!
;
S DIC=2,DIC(0)="AEMQZ"
S DIC("A")="Generate eligibility chk (Med Part D) for which patient? "
F D Q:PATDONE
. D ^DIC
. U $P W !
. ;S:(($G(DUOUT))!($G(DTOUT))!(Y>0)) PATDONE=1 ;RLT - PATCH 15
. S:(($G(DUOUT))!($G(DTOUT))!(Y>0)!(X="")) PATDONE=1 ;RLT - PATCH 15
K DIC
S DUZ(2)=ABSPDUZ2
;
Q Y
GETPHARM() ;when more than one pharmacy is set up for this site, prompt
; for which one to use for the E1 transmission (need to know which
; NCPDP & terminal ID to use)
;
N PHARM,HLDPHARM,Y,PDONE,PHMCNT,DIC
;
S (PHMCNT,PDONE,PHARM,Y)=0 ;initialize beginning variables
;
F S PHARM=$O(^ABSP(9002313.56,PHARM)) Q:'+PHARM D
. S PHMCNT=PHMCNT+1
. S:PHMCNT=1 HLDPHARM=PHARM
Q:PHMCNT=1 HLDPHARM
;
W !!
S DIC=9002313.56,DIC(0)="AEMQZ"
S DIC("B")=$P($G(^ABSP(9002313.56,HLDPHARM,0)),U)
S DIC("A")="Please specify the pharmacy: "
F D Q:PDONE
. D ^DIC
. U $P W !
. S:(($G(DUOUT))!($G(DTOUT))!(Y>0)) PDONE=1
;
Q +Y
;
GETABSPE() ; if an E1 was previously sent for this patient, find it
; and prompt if the user wishes to send again. If one doesn't
; exist, we'll ask fileman to create it for us now.
;
N X,DIC,DLAYGO,Y,NEWE1,CRTNWE1,E1IEN
S DIC="^ABSPE(",DIC(0)="XZ"
;S X=E1PNAM ;RLT - 2/3/06 - Patch 16
S X="`"_E1PIEN ;RLT - 2/3/06 - Patch 16
S (NEWE1,CRTNWE1)=0
;
;let's look for an existing E1 for this patient
D ^DIC
K DIC
S E1IEN=+Y
S:E1IEN<1 CRTNWE1=1 ;patient doesn't exist - add them
S:E1IEN>0 NEWE1=$$PRMPT(E1IEN) ;exist - do they want to send again?
;
; Yes - they want to send again - delete the current entry
I NEWE1 D
. N DIK,DA
. S DIK="^ABSPE("
. S DA=E1IEN
. D ^DIK ;kill the previous entry
. K DIK,DA
. S CRTNWE1=1
;
; creat a new entry
I CRTNWE1 D
. S DIC="^ABSPE("
. ;S X=E1PNAM ;RLT - 2/3/06 - Patch 16
. S X="`"_E1PIEN ;RLT - 2/3/06 - Patch 16
. S DLAYGO=9002313.7,DIC(0)="LXZ"
. D ^DIC
;
Q +Y
;
PRMPT(E1IEN) ; The patient has previously had an E1 sent - if the last response
; was accepted, let's display the previous response and prompt if
; the wants to send another E1 at this time
;
N RESULT,DIR,STATUS
;
; if the previous result was an error, let's send a new E1
S RESULT=$$GET1^DIQ(9002313.7,E1IEN_",",9999999,"E")
Q:RESULT'="" 1
;
; if the status reflects the E1 was rejected, let's send a new one
S STATUS=$$GET1^DIQ(9002313.7,E1IEN_",",112,"E")
Q:STATUS="R" 1
;
;
U $P
W !!!,"A check was previously submitted for this patient: "
D DISPLAY(E1IEN)
;
S DIR("A")="Would you like to send a new eligibility check? "
S DIR("B")="Y"
S DIR(0)="YAO"
D ^DIR
;
Q Y
CRTE1 ; This subroutine will:
; * facilitate the creation of the needed E1 header, patient
; and insurance segments (transmission record is TDATA)
; * update ^ABSPE with the patient/insurance trans data
; * create raw transmission record for ^ABSPE
;
;
N FS,SS
N DIE,DA,DR
;N TDATA
;
S TDATA=""
S DIE="^ABSPE(",DA=E1IEN
S FS=$C(28),SS=$C(30) ;field and segment separators
;
D HEADER
D PATIENT
D INSURER
;
;update ^ABSPE with the patient and insurance information
; for the transmission
;
D ^DIE
;
;update ^ABSPE with raw message
D RAWTRANS
;
Q
;
; for the Medicare Part D transmission. If other E1's are ever produced
; this will need to be altered to pull the plan from some other source.
; Because of the tight time line for the Medicare Part D E1, we forced
; the plan to only work for that plan (006015). The header segment is
; fixed length, will all elements required.
;
; 11/14/05 THIS SUBROUTINE MUST BE REVIEWED AND ADJUSTED FOR GO LIVE -
; CURRENTLY SET TO WORK WITH NDC TROPP FACILITATION TESTING - SEE
; COMMENTS BELOW
;
N XDATA
;
S XDATA=$G(^ABSP(9002313.56,E1PHARM,0)) ;E1PHARM set from call to GETPHARM
;
;101 BIN (Emdeon plan # hard coded to 006015) + 102 Version (always 51) +
;103 Trans Code (always E1)
S TDATA="00601551E1"
;S TDATA="00998851E1" ;Bart's test system
;S TDATA="01172751E1" ;good way to force EV rejection
;
;104 Processor control number (Emdeon terminal id for sending pharmacy)
S TDATA=TDATA_$TR($J($P(XDATA,U,6),10)," ","0")
;
;109 Transaction Count (1 for the E1)+202 Service Prov ID Qual (always 07)
S TDATA=TDATA_107
;
;201 Service Provide ID
S TDATA=TDATA_$$ANFF^ABSPECFM($P(XDATA,U,2),15) ;NCPDP number
;S TDATA=TDATA_$$ANFF^ABSPECFM("1234567",15) ;forces rejection
;S TDATA=TDATA_$$ANFF^ABSPECFM("0000238",15) ;good one for testing
;
;401 Data of Service (will always use current date for the E1)
S TDATA=TDATA_$$DTF1^ABSPECFM(DT)
;
;110 Software Vendor/Certification ID
S TDATA=TDATA_$$ANFF^ABSPECFM(" ",10) ;real?? don't know yet
;S TDATA=TDATA_$$ANFF^ABSPECFM("TATA",10) ;Bart's testing system
;S TDATA=TDATA_$$ANFF^ABSPECFM("TROOPELIG",10) ;NDC's testing system
;
;add segment and field separators
S TDATA=TDATA_SS_FS
;
Q
PATIENT ; This subroutine is responsible for creating the patient segment, and
; for updating the ^ABSPE record with this information.
;
; 11/14/05 CHANGES MAY BE NEEDED - THIS SUBROUTINE IS CURRENTLY SET TO
; WORK WITH NDC TESTING - SEE COMMENTS BELOW
;
N ABSP304,ABSP305,ABSP310,ABSP311,ABSP332,ABSP323,ABSP324
N ABSP325,ABSP326,XDATA,XDATA11,ABSPNAM
;
N STCODE
;
S XDATA=$G(^DPT(E1PIEN,0)) ;patient data
S XDATA11=$G(^DPT(E1PIEN,.11)) ;address information
;
;preset field 111 to AM01 (segment identification)
S TDATA=TDATA_"AM01"_FS
;
;304 Date of Birth (format
S ABSP304=$$DTF1^ABSPECFM($P(XDATA,U,3))
S TDATA=TDATA_"C4"_ABSP304_FS
S DR="304////"_ABSP304_";"
;
;305 Patient Gender
S ABSP305=$E($P(XDATA,U,2),1,1)
S ABSP305=$S(ABSP305="M":"1",ABSP305="F":"2",1:"0")
S ABSP305=$$NFF^ABSPECFM(ABSP305,1)
S TDATA=TDATA_"C5"_ABSP305_FS
S DR=DR_"305////"_ABSP305_";"
;
;prepare for patient name - try to use the entry
; from the Medicare Eligible file is its there, if
; not, use the patient name
S ABSPNAM=$$GET1^DIQ(9000003,E1PIEN_",",.01,"E")
S:ABSPNAM="" ABSPNAM=$P(XDATA,U)
;
;310 Patient First Name
S ABSP310=$$ANFF^ABSPECFM($P($P(ABSPNAM,",",2)," "),12)
S TDATA=TDATA_"CA"_ABSP310_FS
S DR=DR_"310////"_ABSP310_";"
;
;311 Patient Last Name
S ABSP311=$$ANFF^ABSPECFM($P(ABSPNAM,",",1),15)
S TDATA=TDATA_"CB"_ABSP311_FS
S DR=DR_"311////"_ABSP311_";"
;
;322 Patient Street Address - not used yet
;S ABSP322=$$ANFF^ABSPECFM($P(XDATA11,U),30)
;S TDATA=TDATA_"CM"_ABSP322_FS
;S DR=DR_"322////"_ABSP322_";"
;
;323 Patient City Address - not used yet
;S ABSP323=$$ANFF^ABSPECFM($P(XDATA11,U,4),20)
;S TDATA=TDATA_"CN"_ABSP323_FS
;S DR=DR_"323////"_ABSP323_";"
;
;324 Patient State/Province Address - not used yet
;S ABSP324=""
;S STCODE=$P(XDATA11,U,5)
;S:STCODE'="" ABSP324=$P($G(^DIC(5,STCODE,0)),U,2)
;S ABSP324=$$ANFF^ABSPECFM(ABSP324,2)
;S TDATA=TDATA_"CO"_ABSP324_FS
;S DR=DR_"324////"_ABSP324_";"
;
;325 Patient Zip/Postal Zone - currently last field
; so the segment separator must be there
S ABSP325=$$ANFF^ABSPECFM($P(XDATA11,U,6),15)
S TDATA=TDATA_"CP"_ABSP325_SS_FS
S DR=DR_"325////"_ABSP325_";"
;
;326 Patient Phone Number - not used yet
; if they want this, remove the segment separator from
; the zip code
;S ABSP326=$TR($$GET1^DIQ(2,E1PIEN_",",.131,"E"),"()-")
;S ABSP326=$$NFF^ABSPECFM(ABSP326,10)
;S TDATA=TDATA_"CQ"_ABSP326_SS_FS
;S DR=DR_"326////"_ABSP326_";"
;
Q
INSURER ; this subroutine will pull together the information
; needed for the E1 insurance segment
;
; 11/15/05 CHANGES MAY BE NEEDED - THIS ROUTINE IS SET
; TO WORK WITH NDC TROOP FACILITATION TESTING - SEE
; COMMENTS BELOW
;
N ABSP302,ABSP301,ABSPCID
;
S TDATA=TDATA_"AM04"_FS
;
;302 Cardholder ID - will try to retrieve medicare card holder
; id, if not available use last 4 of SSN
S ABSP302=$$GET1^DIQ(9000003,E1PIEN_",",.03,"E")
I ABSP302="" D
. S ABSP302=$$GET1^DIQ(2,E1PIEN_",",.09,"E")
. S ABSP302=$E(ABSP302,$L(ABSP302)-3,$L(ABSP302))
;
S ABSP302=$TR(ABSP302,"-/.","")
S ABSP302=$$ANFF^ABSPECFM(ABSP302,20)
S TDATA=TDATA_"C2"_ABSP302
;S TDATA=TDATA_"C2"_ABSP302_FS ; Bart's system
S DR=DR_"302////"_ABSP302
;
;301 group number - just for testing
; Bart's system - don't know if this fld
; will be needed for live - put the fld
; separator on 302 (above) if 301 is needed
;S ABSP301=$$ANFF^ABSPECFM("TATA",10)
;S TDATA=TDATA_"C1"_ABSP301
;S DR=DR_"301////"_ABSP301
;
Q
RAWTRANS ; create the raw transmission entry in ^ABSPE
;
N WP,I,ZERR ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
;
F I=1:100:$L(TDATA) S WP(I/100+1,0)=$E(TDATA,I,I+99)
D WP^DIE(9002313.7,E1IEN_",",1000,"","WP","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
I $D(ZERR) D LOG^ABSPOSL2("RAWTRANS^ABSPOSE1",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
Q
DISPLAY(E1IEN) ;EP - display the E1's results
;
N ABSPPNAM,ABSP112,ABSP504,ABSP526,ABSPINS,COVER
N ABSP503,ABSPCUT,ABSPSTR,ABSP03
S (ABSPPNAM,ABSP112,ABSP504,ABSP503,ABSP536)=""
;
S ABSPPNAM=$$GET1^DIQ(9002313.7,E1IEN_",",.01,"E")
S ABSP03=$$GET1^DIQ(9002313.7,E1IEN_",",.03,"E")
S ABSP112=$$GET1^DIQ(9002313.7,E1IEN_",",112,"E")
S ABSP503=$$GET1^DIQ(9002313.7,E1IEN_",",503,"E")
S ABSP504=$$GET1^DIQ(9002313.7,E1IEN_",",504,"E")
S ABSP526=$$GET1^DIQ(9002313.7,E1IEN_",",526,"E")
S ABSPINS=ABSP504_ABSP526
D:ABSPINS["&" PARSEIT(ABSPINS,.COVER)
;
W !,"On: ",ABSP03
W !,"Patient Name: ",ABSPPNAM
W !,"Status: ",ABSP112
W !,"Authorization #: ",ABSP503
;
I '$D(COVER("COUNT")) D
. W !,"Result:"
. ;
. N LINECNT ;RLT - 2/3/06 - Patch 16
. S LINECNT=1 ;RLT - 2/3/06 - Patch 16
. ;
. I $D(ABSP504) D
.. S ABSPSTR=1
.. I $L(ABSP504)>50 D ;RLT - 2/3/06 - Patch 16
... S LINECNT=$L(ABSP504)\50 ;RLT - 2/3/06 - Patch 16
... S:LINECNT#50'=0 LINECNT=LINECNT+1 ;RLT - 2/3/06 - Patch 16
.. F ABSPCUT=1:1:LINECNT D ;RLT - 2/3/06 - Patch 16
... W ?18,$E(ABSP504,ABSPSTR,ABSPSTR+50),!," "
... S ABSPSTR=ABSPSTR+50
. ;
. S LINECNT=1
. ;
. I $D(ABSP526) D
.. S ABSPSTR=1
.. I $L(ABSP526)>50 D ;RLT - 2/3/06 - Patch 16
... S LINECNT=$L(ABSP526)\50 ;RLT - 2/3/06 - Patch 16
... S:LINECNT#50'=0 LINECNT=LINECNT+1 ;RLT - 2/3/06 - Patch 16
.. F ABSPCUT=1:1:LINECNT D ;RLT - 2/3/06 - Patch 16
... W ?18,$E(ABSP526,ABSPSTR,ABSPSTR+50),!," "
... S ABSPSTR=ABSPSTR+50
. ;
. W !!
;
F INSCNT=1:1:$G(COVER("COUNT")) D
. W !,"Insurance Level: ",COVER(INSCNT,"INS LVL")
. W !," BIN: ",COVER(INSCNT,"BIN")
. W !," PCN: ",COVER(INSCNT,"PCN")
. W !," GROUP: ",COVER(INSCNT,"GROUP")
. W !," CARDHOLDER ID: ",COVER(INSCNT,"CARD ID")
. W !," PERSON CODE: ",COVER(INSCNT,"PERSON CD")
. W !," PHONE NUMBER: ",COVER(INSCNT,"PHONE #")
. W !
;
;
Q
;
PARSEIT(INSFLD,COVER) ; The 504 and 526 fields may actually have
; detailed insurance information in them - we need to break
; them down for reporting purposes.
;
N INSCNT,NOMORE
S INSCNT=1
S NOMORE=0
;
F D Q:NOMORE
. S INSREC=$P(INSFLD,"&",INSCNT)
. S:INSREC="" NOMORE=1
. Q:NOMORE
. I INSCNT=1 D
.. S COVER(INSCNT,"INS LVL")=$P(INSREC,"#",2)
.. S COVER(INSCNT,"BIN")=$P($P(INSREC,"#",3),":",2)
.. S COVER(INSCNT,"PCN")=$P($P(INSREC,"#",4),":",2)
.. S COVER(INSCNT,"GROUP")=$P($P(INSREC,"#",5),":",2)
.. S COVER(INSCNT,"CARD ID")=$P($P(INSREC,"#",6),":",2)
.. S COVER(INSCNT,"PERSON CD")=$P($P(INSREC,"#",7),":",2)
.. S COVER(INSCNT,"PHONE #")=$P($P(INSREC,"#",8),":",2)
. I INSCNT'=1 D
.. S COVER(INSCNT,"INS LVL")=$P(INSREC,"#")
.. S COVER(INSCNT,"BIN")=$P($P(INSREC,"#",2),":",2)
.. S COVER(INSCNT,"PCN")=$P($P(INSREC,"#",3),":",2)
.. S COVER(INSCNT,"GROUP")=$P($P(INSREC,"#",4),":",2)
.. S COVER(INSCNT,"CARD ID")=$P($P(INSREC,"#",5),":",2)
.. S COVER(INSCNT,"PERSON CD")=$P($P(INSREC,"#",6),":",2)
.. S COVER(INSCNT,"PHONE #")=$P($P(INSREC,"#",7),":",2)
. S INSCNT=INSCNT+1
;
S COVER("COUNT")=INSCNT-1
;
Q
ABSPOSE1 ; IHS/SD/lwj - E1 gereration routine ; [ 10/24/2005 10:09:07 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**14,15,16,48**;JUN 21, 2001;Build 38
+2 ;
+3 ;IHS/SD/lwj 10/24/05 Medicare Part D E1 Transmission routine
+4 ; This routine will:
+5 ; * prompt the user for which patient an E1 should be generated for
+6 ; * determine if there are multiple pharmacies and prompt for one
+7 ; * determine if a previous E1 was sent - if so, it will prompt if
+8 ; the user would like to create a new E1
+9 ; * create the shell of the ^ABSPE entry
+10 ; * generate the E1 transmission
+11 ; * call ^ABSPOSAE to send the E1 and process the response
+12 ; * prompt for another patient
+13 ;
+14 ; 11/15/05 WE WERE ONLY ABLE TO TEST WITH NDC TROOP FACILITATION -
+15 ; ADJUSTMENTS WILL BE NEEDED WHEN WE KNOW MORE AND ARE READY TO
+16 ; GO LIVE.
+17 ;
+18 ; IHS/SD/RLT - 1/13/06 - Patch 15
+19 ; Pam Swchweitzer requested the program to end when a blank
+20 ; patient is entered.
+21 ;
+22 ; IHS/SD/RLT - 2/3/06 - Patch 16
+23 ; Fixed display error for fields 504 and 526.
+24 ;
+25 ; Fixed elig file write and lookup. Changed X from name to `IEN so
+26 ; fileman is not confused on names that bring up muliple records.
+27 ;
+28 QUIT
MAIN ;EP
+1 NEW POP
+2 SET POP=0
+3 ;
+4 FOR
DO PROCESS
IF POP
QUIT
+5 ;
+6 QUIT
PROCESS ;
+1 NEW E1PNAM,E1PIEN,E1PINFO,E1PHARM,E1IEN
+2 ;
+3 SET POP=1
+4 ; prompt for the patient
+5 SET E1PINFO=$$GETPAT
+6 IF E1PINFO<1
QUIT
+7 ;VA(200 patient IEN
SET E1PIEN=$PIECE(E1PINFO,U)
+8 ;VA(200 patient name
SET E1PNAM=$PIECE(E1PINFO,U,2)
+9 ;
+10 ; determine the pharmacy to send on behalf of
+11 ;E1PHARM - ien into ABSP(9002313.56
SET E1PHARM=$$GETPHARM
+12 IF E1PHARM<1
QUIT
+13 ;
+14 ; establish the ^ABSPE record to work with
+15 ;E1IEN - ien into ^ABSPE
SET E1IEN=$$GETABSPE
+16 ;must have had a prev one and didn't want a new one
IF E1IEN<1
QUIT
+17 ;
+18 ;create the transmission
+19 DO CRTE1
+20 USE $PRINCIPAL
WRITE !!,"Transmitting eligibility check, please stand by.....",!!
+21 ;send the transaction
DO SEND^ABSPOSAE(TDATA,E1IEN)
+22 SET POP=0
+23 ;
+24 ;
+25 ;
+26 QUIT
GETPAT() ;Prompt the user for which patient they would like to generate an E1 for
+1 ;
+2 NEW ABSPDUZ2,PATDONE,Y,DIC
+3 ;RLT - Patch 15
NEW X
+4 ;RLT - Patch 15
SET X=""
+5 ;
+6 ;set to one when we are done prompting
SET PATDONE=0
+7 SET Y=0
+8 SET ABSPDUZ2=+$GET(DUZ(2))
SET DUZ(2)=0
+9 ;
+10 USE $PRINCIPAL
WRITE !!!
+11 ;
+12 SET DIC=2
SET DIC(0)="AEMQZ"
+13 SET DIC("A")="Generate eligibility chk (Med Part D) for which patient? "
+14 FOR
Begin DoDot:1
+15 DO ^DIC
+16 USE $PRINCIPAL
WRITE !
+17 ;S:(($G(DUOUT))!($G(DTOUT))!(Y>0)) PATDONE=1 ;RLT - PATCH 15
+18 ;RLT - PATCH 15
IF (($GET(DUOUT))!($GET(DTOUT))!(Y>0)!(X=""))
SET PATDONE=1
End DoDot:1
IF PATDONE
QUIT
+19 KILL DIC
+20 SET DUZ(2)=ABSPDUZ2
+21 ;
+22 QUIT Y
GETPHARM() ;when more than one pharmacy is set up for this site, prompt
+1 ; for which one to use for the E1 transmission (need to know which
+2 ; NCPDP & terminal ID to use)
+3 ;
+4 NEW PHARM,HLDPHARM,Y,PDONE,PHMCNT,DIC
+5 ;
+6 ;initialize beginning variables
SET (PHMCNT,PDONE,PHARM,Y)=0
+7 ;
+8 FOR
SET PHARM=$ORDER(^ABSP(9002313.56,PHARM))
IF '+PHARM
QUIT
Begin DoDot:1
+9 SET PHMCNT=PHMCNT+1
+10 IF PHMCNT=1
SET HLDPHARM=PHARM
End DoDot:1
+11 IF PHMCNT=1
QUIT HLDPHARM
+12 ;
+13 WRITE !!
+14 SET DIC=9002313.56
SET DIC(0)="AEMQZ"
+15 SET DIC("B")=$PIECE($GET(^ABSP(9002313.56,HLDPHARM,0)),U)
+16 SET DIC("A")="Please specify the pharmacy: "
+17 FOR
Begin DoDot:1
+18 DO ^DIC
+19 USE $PRINCIPAL
WRITE !
+20 IF (($GET(DUOUT))!($GET(DTOUT))!(Y>0))
SET PDONE=1
End DoDot:1
IF PDONE
QUIT
+21 ;
+22 QUIT +Y
+23 ;
GETABSPE() ; if an E1 was previously sent for this patient, find it
+1 ; and prompt if the user wishes to send again. If one doesn't
+2 ; exist, we'll ask fileman to create it for us now.
+3 ;
+4 NEW X,DIC,DLAYGO,Y,NEWE1,CRTNWE1,E1IEN
+5 SET DIC="^ABSPE("
SET DIC(0)="XZ"
+6 ;S X=E1PNAM ;RLT - 2/3/06 - Patch 16
+7 ;RLT - 2/3/06 - Patch 16
SET X="`"_E1PIEN
+8 SET (NEWE1,CRTNWE1)=0
+9 ;
+10 ;let's look for an existing E1 for this patient
+11 DO ^DIC
+12 KILL DIC
+13 SET E1IEN=+Y
+14 ;patient doesn't exist - add them
IF E1IEN<1
SET CRTNWE1=1
+15 ;exist - do they want to send again?
IF E1IEN>0
SET NEWE1=$$PRMPT(E1IEN)
+16 ;
+17 ; Yes - they want to send again - delete the current entry
+18 IF NEWE1
Begin DoDot:1
+19 NEW DIK,DA
+20 SET DIK="^ABSPE("
+21 SET DA=E1IEN
+22 ;kill the previous entry
DO ^DIK
+23 KILL DIK,DA
+24 SET CRTNWE1=1
End DoDot:1
+25 ;
+26 ; creat a new entry
+27 IF CRTNWE1
Begin DoDot:1
+28 SET DIC="^ABSPE("
+29 ;S X=E1PNAM ;RLT - 2/3/06 - Patch 16
+30 ;RLT - 2/3/06 - Patch 16
SET X="`"_E1PIEN
+31 SET DLAYGO=9002313.7
SET DIC(0)="LXZ"
+32 DO ^DIC
End DoDot:1
+33 ;
+34 QUIT +Y
+35 ;
PRMPT(E1IEN) ; The patient has previously had an E1 sent - if the last response
+1 ; was accepted, let's display the previous response and prompt if
+2 ; the wants to send another E1 at this time
+3 ;
+4 NEW RESULT,DIR,STATUS
+5 ;
+6 ; if the previous result was an error, let's send a new E1
+7 SET RESULT=$$GET1^DIQ(9002313.7,E1IEN_",",9999999,"E")
+8 IF RESULT'=""
QUIT 1
+9 ;
+10 ; if the status reflects the E1 was rejected, let's send a new one
+11 SET STATUS=$$GET1^DIQ(9002313.7,E1IEN_",",112,"E")
+12 IF STATUS="R"
QUIT 1
+13 ;
+14 ;
+15 USE $PRINCIPAL
+16 WRITE !!!,"A check was previously submitted for this patient: "
+17 DO DISPLAY(E1IEN)
+18 ;
+19 SET DIR("A")="Would you like to send a new eligibility check? "
+20 SET DIR("B")="Y"
+21 SET DIR(0)="YAO"
+22 DO ^DIR
+23 ;
+24 QUIT Y
CRTE1 ; This subroutine will:
+1 ; * facilitate the creation of the needed E1 header, patient
+2 ; and insurance segments (transmission record is TDATA)
+3 ; * update ^ABSPE with the patient/insurance trans data
+4 ; * create raw transmission record for ^ABSPE
+5 ;
+6 ;
+7 NEW FS,SS
+8 NEW DIE,DA,DR
+9 ;N TDATA
+10 ;
+11 SET TDATA=""
+12 SET DIE="^ABSPE("
SET DA=E1IEN
+13 ;field and segment separators
SET FS=$CHAR(28)
SET SS=$CHAR(30)
+14 ;
+15 DO HEADER
+16 DO PATIENT
+17 DO INSURER
+18 ;
+19 ;update ^ABSPE with the patient and insurance information
+20 ; for the transmission
+21 ;
+22 DO ^DIE
+23 ;
+24 ;update ^ABSPE with raw message
+25 DO RAWTRANS
+26 ;
+27 QUIT
+28 ;
+1 ; for the Medicare Part D transmission. If other E1's are ever produced
+2 ; this will need to be altered to pull the plan from some other source.
+3 ; Because of the tight time line for the Medicare Part D E1, we forced
+4 ; the plan to only work for that plan (006015). The header segment is
+5 ; fixed length, will all elements required.
+6 ;
+7 ; 11/14/05 THIS SUBROUTINE MUST BE REVIEWED AND ADJUSTED FOR GO LIVE -
+8 ; CURRENTLY SET TO WORK WITH NDC TROPP FACILITATION TESTING - SEE
+9 ; COMMENTS BELOW
+10 ;
+11 NEW XDATA
+12 ;
+13 ;E1PHARM set from call to GETPHARM
SET XDATA=$GET(^ABSP(9002313.56,E1PHARM,0))
+14 ;
+15 ;101 BIN (Emdeon plan # hard coded to 006015) + 102 Version (always 51) +
+16 ;103 Trans Code (always E1)
+17 SET TDATA="00601551E1"
+18 ;S TDATA="00998851E1" ;Bart's test system
+19 ;S TDATA="01172751E1" ;good way to force EV rejection
+20 ;
+21 ;104 Processor control number (Emdeon terminal id for sending pharmacy)
+22 SET TDATA=TDATA_$TRANSLATE($JUSTIFY($PIECE(XDATA,U,6),10)," ","0")
+23 ;
+24 ;109 Transaction Count (1 for the E1)+202 Service Prov ID Qual (always 07)
+25 SET TDATA=TDATA_107
+26 ;
+27 ;201 Service Provide ID
+28 ;NCPDP number
SET TDATA=TDATA_$$ANFF^ABSPECFM($PIECE(XDATA,U,2),15)
+29 ;S TDATA=TDATA_$$ANFF^ABSPECFM("1234567",15) ;forces rejection
+30 ;S TDATA=TDATA_$$ANFF^ABSPECFM("0000238",15) ;good one for testing
+31 ;
+32 ;401 Data of Service (will always use current date for the E1)
+33 SET TDATA=TDATA_$$DTF1^ABSPECFM(DT)
+34 ;
+35 ;110 Software Vendor/Certification ID
+36 ;real?? don't know yet
SET TDATA=TDATA_$$ANFF^ABSPECFM(" ",10)
+37 ;S TDATA=TDATA_$$ANFF^ABSPECFM("TATA",10) ;Bart's testing system
+38 ;S TDATA=TDATA_$$ANFF^ABSPECFM("TROOPELIG",10) ;NDC's testing system
+39 ;
+40 ;add segment and field separators
+41 SET TDATA=TDATA_SS_FS
+42 ;
+43 QUIT
PATIENT ; This subroutine is responsible for creating the patient segment, and
+1 ; for updating the ^ABSPE record with this information.
+2 ;
+3 ; 11/14/05 CHANGES MAY BE NEEDED - THIS SUBROUTINE IS CURRENTLY SET TO
+4 ; WORK WITH NDC TESTING - SEE COMMENTS BELOW
+5 ;
+6 NEW ABSP304,ABSP305,ABSP310,ABSP311,ABSP332,ABSP323,ABSP324
+7 NEW ABSP325,ABSP326,XDATA,XDATA11,ABSPNAM
+8 ;
+9 NEW STCODE
+10 ;
+11 ;patient data
SET XDATA=$GET(^DPT(E1PIEN,0))
+12 ;address information
SET XDATA11=$GET(^DPT(E1PIEN,.11))
+13 ;
+14 ;preset field 111 to AM01 (segment identification)
+15 SET TDATA=TDATA_"AM01"_FS
+16 ;
+17 ;304 Date of Birth (format
+18 SET ABSP304=$$DTF1^ABSPECFM($PIECE(XDATA,U,3))
+19 SET TDATA=TDATA_"C4"_ABSP304_FS
+20 SET DR="304////"_ABSP304_";"
+21 ;
+22 ;305 Patient Gender
+23 SET ABSP305=$EXTRACT($PIECE(XDATA,U,2),1,1)
+24 SET ABSP305=$SELECT(ABSP305="M":"1",ABSP305="F":"2",1:"0")
+25 SET ABSP305=$$NFF^ABSPECFM(ABSP305,1)
+26 SET TDATA=TDATA_"C5"_ABSP305_FS
+27 SET DR=DR_"305////"_ABSP305_";"
+28 ;
+29 ;prepare for patient name - try to use the entry
+30 ; from the Medicare Eligible file is its there, if
+31 ; not, use the patient name
+32 SET ABSPNAM=$$GET1^DIQ(9000003,E1PIEN_",",.01,"E")
+33 IF ABSPNAM=""
SET ABSPNAM=$PIECE(XDATA,U)
+34 ;
+35 ;310 Patient First Name
+36 SET ABSP310=$$ANFF^ABSPECFM($PIECE($PIECE(ABSPNAM,",",2)," "),12)
+37 SET TDATA=TDATA_"CA"_ABSP310_FS
+38 SET DR=DR_"310////"_ABSP310_";"
+39 ;
+40 ;311 Patient Last Name
+41 SET ABSP311=$$ANFF^ABSPECFM($PIECE(ABSPNAM,",",1),15)
+42 SET TDATA=TDATA_"CB"_ABSP311_FS
+43 SET DR=DR_"311////"_ABSP311_";"
+44 ;
+45 ;322 Patient Street Address - not used yet
+46 ;S ABSP322=$$ANFF^ABSPECFM($P(XDATA11,U),30)
+47 ;S TDATA=TDATA_"CM"_ABSP322_FS
+48 ;S DR=DR_"322////"_ABSP322_";"
+49 ;
+50 ;323 Patient City Address - not used yet
+51 ;S ABSP323=$$ANFF^ABSPECFM($P(XDATA11,U,4),20)
+52 ;S TDATA=TDATA_"CN"_ABSP323_FS
+53 ;S DR=DR_"323////"_ABSP323_";"
+54 ;
+55 ;324 Patient State/Province Address - not used yet
+56 ;S ABSP324=""
+57 ;S STCODE=$P(XDATA11,U,5)
+58 ;S:STCODE'="" ABSP324=$P($G(^DIC(5,STCODE,0)),U,2)
+59 ;S ABSP324=$$ANFF^ABSPECFM(ABSP324,2)
+60 ;S TDATA=TDATA_"CO"_ABSP324_FS
+61 ;S DR=DR_"324////"_ABSP324_";"
+62 ;
+63 ;325 Patient Zip/Postal Zone - currently last field
+64 ; so the segment separator must be there
+65 SET ABSP325=$$ANFF^ABSPECFM($PIECE(XDATA11,U,6),15)
+66 SET TDATA=TDATA_"CP"_ABSP325_SS_FS
+67 SET DR=DR_"325////"_ABSP325_";"
+68 ;
+69 ;326 Patient Phone Number - not used yet
+70 ; if they want this, remove the segment separator from
+71 ; the zip code
+72 ;S ABSP326=$TR($$GET1^DIQ(2,E1PIEN_",",.131,"E"),"()-")
+73 ;S ABSP326=$$NFF^ABSPECFM(ABSP326,10)
+74 ;S TDATA=TDATA_"CQ"_ABSP326_SS_FS
+75 ;S DR=DR_"326////"_ABSP326_";"
+76 ;
+77 QUIT
INSURER ; this subroutine will pull together the information
+1 ; needed for the E1 insurance segment
+2 ;
+3 ; 11/15/05 CHANGES MAY BE NEEDED - THIS ROUTINE IS SET
+4 ; TO WORK WITH NDC TROOP FACILITATION TESTING - SEE
+5 ; COMMENTS BELOW
+6 ;
+7 NEW ABSP302,ABSP301,ABSPCID
+8 ;
+9 SET TDATA=TDATA_"AM04"_FS
+10 ;
+11 ;302 Cardholder ID - will try to retrieve medicare card holder
+12 ; id, if not available use last 4 of SSN
+13 SET ABSP302=$$GET1^DIQ(9000003,E1PIEN_",",.03,"E")
+14 IF ABSP302=""
Begin DoDot:1
+15 SET ABSP302=$$GET1^DIQ(2,E1PIEN_",",.09,"E")
+16 SET ABSP302=$EXTRACT(ABSP302,$LENGTH(ABSP302)-3,$LENGTH(ABSP302))
End DoDot:1
+17 ;
+18 SET ABSP302=$TRANSLATE(ABSP302,"-/.","")
+19 SET ABSP302=$$ANFF^ABSPECFM(ABSP302,20)
+20 SET TDATA=TDATA_"C2"_ABSP302
+21 ;S TDATA=TDATA_"C2"_ABSP302_FS ; Bart's system
+22 SET DR=DR_"302////"_ABSP302
+23 ;
+24 ;301 group number - just for testing
+25 ; Bart's system - don't know if this fld
+26 ; will be needed for live - put the fld
+27 ; separator on 302 (above) if 301 is needed
+28 ;S ABSP301=$$ANFF^ABSPECFM("TATA",10)
+29 ;S TDATA=TDATA_"C1"_ABSP301
+30 ;S DR=DR_"301////"_ABSP301
+31 ;
+32 QUIT
RAWTRANS ; create the raw transmission entry in ^ABSPE
+1 ;
+2 ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
NEW WP,I,ZERR
+3 ;
+4 FOR I=1:100:$LENGTH(TDATA)
SET WP(I/100+1,0)=$EXTRACT(TDATA,I,I+99)
+5 ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
DO WP^DIE(9002313.7,E1IEN_",",1000,"","WP","ZERR")
+6 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(ZERR)
DO LOG^ABSPOSL2("RAWTRANS^ABSPOSE1",.ZERR)
+7 ;
+8 QUIT
DISPLAY(E1IEN) ;EP - display the E1's results
+1 ;
+2 NEW ABSPPNAM,ABSP112,ABSP504,ABSP526,ABSPINS,COVER
+3 NEW ABSP503,ABSPCUT,ABSPSTR,ABSP03
+4 SET (ABSPPNAM,ABSP112,ABSP504,ABSP503,ABSP536)=""
+5 ;
+6 SET ABSPPNAM=$$GET1^DIQ(9002313.7,E1IEN_",",.01,"E")
+7 SET ABSP03=$$GET1^DIQ(9002313.7,E1IEN_",",.03,"E")
+8 SET ABSP112=$$GET1^DIQ(9002313.7,E1IEN_",",112,"E")
+9 SET ABSP503=$$GET1^DIQ(9002313.7,E1IEN_",",503,"E")
+10 SET ABSP504=$$GET1^DIQ(9002313.7,E1IEN_",",504,"E")
+11 SET ABSP526=$$GET1^DIQ(9002313.7,E1IEN_",",526,"E")
+12 SET ABSPINS=ABSP504_ABSP526
+13 IF ABSPINS["&"
DO PARSEIT(ABSPINS,.COVER)
+14 ;
+15 WRITE !,"On: ",ABSP03
+16 WRITE !,"Patient Name: ",ABSPPNAM
+17 WRITE !,"Status: ",ABSP112
+18 WRITE !,"Authorization #: ",ABSP503
+19 ;
+20 IF '$DATA(COVER("COUNT"))
Begin DoDot:1
+21 WRITE !,"Result:"
+22 ;
+23 ;RLT - 2/3/06 - Patch 16
NEW LINECNT
+24 ;RLT - 2/3/06 - Patch 16
SET LINECNT=1
+25 ;
+26 IF $DATA(ABSP504)
Begin DoDot:2
+27 SET ABSPSTR=1
+28 ;RLT - 2/3/06 - Patch 16
IF $LENGTH(ABSP504)>50
Begin DoDot:3
+29 ;RLT - 2/3/06 - Patch 16
SET LINECNT=$LENGTH(ABSP504)\50
+30 ;RLT - 2/3/06 - Patch 16
IF LINECNT#50'=0
SET LINECNT=LINECNT+1
End DoDot:3
+31 ;RLT - 2/3/06 - Patch 16
FOR ABSPCUT=1:1:LINECNT
Begin DoDot:3
+32 WRITE ?18,$EXTRACT(ABSP504,ABSPSTR,ABSPSTR+50),!," "
+33 SET ABSPSTR=ABSPSTR+50
End DoDot:3
End DoDot:2
+34 ;
+35 SET LINECNT=1
+36 ;
+37 IF $DATA(ABSP526)
Begin DoDot:2
+38 SET ABSPSTR=1
+39 ;RLT - 2/3/06 - Patch 16
IF $LENGTH(ABSP526)>50
Begin DoDot:3
+40 ;RLT - 2/3/06 - Patch 16
SET LINECNT=$LENGTH(ABSP526)\50
+41 ;RLT - 2/3/06 - Patch 16
IF LINECNT#50'=0
SET LINECNT=LINECNT+1
End DoDot:3
+42 ;RLT - 2/3/06 - Patch 16
FOR ABSPCUT=1:1:LINECNT
Begin DoDot:3
+43 WRITE ?18,$EXTRACT(ABSP526,ABSPSTR,ABSPSTR+50),!," "
+44 SET ABSPSTR=ABSPSTR+50
End DoDot:3
End DoDot:2
+45 ;
+46 WRITE !!
End DoDot:1
+47 ;
+48 FOR INSCNT=1:1:$GET(COVER("COUNT"))
Begin DoDot:1
+49 WRITE !,"Insurance Level: ",COVER(INSCNT,"INS LVL")
+50 WRITE !," BIN: ",COVER(INSCNT,"BIN")
+51 WRITE !," PCN: ",COVER(INSCNT,"PCN")
+52 WRITE !," GROUP: ",COVER(INSCNT,"GROUP")
+53 WRITE !," CARDHOLDER ID: ",COVER(INSCNT,"CARD ID")
+54 WRITE !," PERSON CODE: ",COVER(INSCNT,"PERSON CD")
+55 WRITE !," PHONE NUMBER: ",COVER(INSCNT,"PHONE #")
+56 WRITE !
End DoDot:1
+57 ;
+58 ;
+59 QUIT
+60 ;
PARSEIT(INSFLD,COVER) ; The 504 and 526 fields may actually have
+1 ; detailed insurance information in them - we need to break
+2 ; them down for reporting purposes.
+3 ;
+4 NEW INSCNT,NOMORE
+5 SET INSCNT=1
+6 SET NOMORE=0
+7 ;
+8 FOR
Begin DoDot:1
+9 SET INSREC=$PIECE(INSFLD,"&",INSCNT)
+10 IF INSREC=""
SET NOMORE=1
+11 IF NOMORE
QUIT
+12 IF INSCNT=1
Begin DoDot:2
+13 SET COVER(INSCNT,"INS LVL")=$PIECE(INSREC,"#",2)
+14 SET COVER(INSCNT,"BIN")=$PIECE($PIECE(INSREC,"#",3),":",2)
+15 SET COVER(INSCNT,"PCN")=$PIECE($PIECE(INSREC,"#",4),":",2)
+16 SET COVER(INSCNT,"GROUP")=$PIECE($PIECE(INSREC,"#",5),":",2)
+17 SET COVER(INSCNT,"CARD ID")=$PIECE($PIECE(INSREC,"#",6),":",2)
+18 SET COVER(INSCNT,"PERSON CD")=$PIECE($PIECE(INSREC,"#",7),":",2)
+19 SET COVER(INSCNT,"PHONE #")=$PIECE($PIECE(INSREC,"#",8),":",2)
End DoDot:2
+20 IF INSCNT'=1
Begin DoDot:2
+21 SET COVER(INSCNT,"INS LVL")=$PIECE(INSREC,"#")
+22 SET COVER(INSCNT,"BIN")=$PIECE($PIECE(INSREC,"#",2),":",2)
+23 SET COVER(INSCNT,"PCN")=$PIECE($PIECE(INSREC,"#",3),":",2)
+24 SET COVER(INSCNT,"GROUP")=$PIECE($PIECE(INSREC,"#",4),":",2)
+25 SET COVER(INSCNT,"CARD ID")=$PIECE($PIECE(INSREC,"#",5),":",2)
+26 SET COVER(INSCNT,"PERSON CD")=$PIECE($PIECE(INSREC,"#",6),":",2)
+27 SET COVER(INSCNT,"PHONE #")=$PIECE($PIECE(INSREC,"#",7),":",2)
End DoDot:2
+28 SET INSCNT=INSCNT+1
End DoDot:1
IF NOMORE
QUIT
+29 ;
+30 SET COVER("COUNT")=INSCNT-1
+31 ;
+32 QUIT
