ABSPOSE2 ; IHS/SD/lwj - E1 generation routine ; [ 10/24/2005 10:09:07 AM ]
;;1.0;PHARMACY POINT OF SALE;**21,24,40,42,48**;JUN 21, 2001;Build 38
;
;IHS/SD/RLT - 05/22/07 - Patch 21
; Enhanced E1 - modified version of ABSPOSE1
; See comments in ABSPOSE1 for further E1 details
;
;IHS/SD/RLT - 02/13/08 - Patch 24
; Fixed Medicare name and DOB lookup (IM27373)
Q
MAIN ;EP
N POP
S POP=0
;
F D PROCESS Q:POP
;
Q
PROCESS ;
N E1PNAM,E1PIEN,E1PINFO,E1PHARM,E1IEN,E1DATE
;
S POP=1
; get 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
;
; get pharmacy
S E1PHARM=$$GETPHARM ;ien ^ABSP(9002313.56
Q:E1PHARM<1
;
; get ^ABSPE rec
S E1IEN=$$GETABSPE ;ien ^ABSPE
Q:E1IEN<1 ;had prev one, didn't want new one
;
S E1DATE=$$GETDATE ;E1DATE - service date sent in header
Q:E1DATE=""
;
; create transmission
D CRTE1
U $P W !!,"Transmitting eligibility check, please stand by.....",!!
D SEND^ABSPOSAE(TDATA,E1IEN) ;send trans
S POP=0
;
Q
GETPAT() ; Prompt for patient.
;
N ABSPDUZ2,PATDONE,Y,DIC
N X
S X=""
;
S PATDONE=0 ;set to one when 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)!(X="")) PATDONE=1
K DIC
S DUZ(2)=ABSPDUZ2
;
Q Y
GETPHARM() ; Prompt for pharmacy.
;
N PHARM,HLDPHARM,Y,PDONE,PHMCNT,DIC
;
S (PHMCNT,PDONE,PHARM,Y)=0
;
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
GETDATE() ; Prompt for service date.
N CURDISP,X1,X2,BEGDT,ENDDT,E1DT
;
S Y=DT
D DD^%DT
S CURDISP=Y
;
S X1=DT,X2=-90
D C^%DTC
S BEGDT=X
S Y=X
D DD^%DT
S BEGDISP=Y
;
S X1=DT,X2=+90
D C^%DTC
S ENDDT=X
S Y=X
D DD^%DT
S ENDDISP=Y
;
W !,"Accept the default current date of ",CURDISP," or"
W !,"Enter a date between ",BEGDISP," and ",ENDDISP,!
S E1DT=$$DATE^ABSPOSU1("Enter Service Date: ",DT,0,BEGDT,ENDDT,"EX")
S:E1DT="^"!(E1DT="^^")!(E1DT=-1) E1DT=""
Q E1DT
;
GETABSPE() ; If E1 previously sent, find it and prompt to send again.
; If doesn't exist, create new one.
;
N X,DIC,DLAYGO,Y,NEWE1,CRTNWE1,E1IEN
S DIC="^ABSPE(",DIC(0)="XZ"
S X="`"_E1PIEN
S (NEWE1,CRTNWE1)=0
;
;look for old E1
D ^DIC
K DIC
S E1IEN=+Y
S:E1IEN<1 CRTNWE1=1 ;doesn't exist - add
S:E1IEN>0 NEWE1=$$PRMPT(E1IEN) ;exist - send again?
;
; Yes, send again - delete old entry
I NEWE1 D
. N DIK,DA
. S DIK="^ABSPE("
. S DA=E1IEN
. D ^DIK
. K DIK,DA
. S CRTNWE1=1
;
; create new entry
I CRTNWE1 D
. S DIC="^ABSPE("
. S X="`"_E1PIEN
. S DLAYGO=9002313.7,DIC(0)="LXZ"
. D ^DIC
;
Q +Y
;
PRMPT(E1IEN) ;Display previous response and prompt to send again.
;
N RESULT,DIR,STATUS
;
; if previous result an error, send new E1
S RESULT=$$GET1^DIQ(9002313.7,E1IEN_",",9999999,"E")
Q:RESULT'="" 1
;
; if status rejected, send new E1
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" ;IHS/OIT/CNI/SCR patch 40 change default answer to "N"
S DIR("B")="N"
S DIR(0)="YAO"
D ^DIR
;
Q Y
CRTE1 ; Creates transmission record, updates ^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
;
D ^DIE
;
;update ^ABSPE with raw message
D RAWTRANS
;
Q
;
;
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="00102451E1" ;Troop extended elig response
; IHS/OIT/CASSevern/Pieran/RAN 10/31/2011 Patch 42 Allow us to send D.0 version of Troop Eligibility
S:$D(^ABSP(9002313.99,1,"ABSPICNV")) TDATA="011727D0E1"
;
;104 Processor control number (Emdeon terminal id for sending pharmacy)
S TDATA=TDATA_$S($D(^ABSP(9002313.99,1,"ABSPICNV")):2222222222,1:$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 Provider ID
S TDATA=TDATA_$$ANFF^ABSPECFM($P(XDATA,U,2),15) ;NCPDP number
;S TDATA=TDATA_$$ANFF^ABSPECFM("1234567",15) ;forces rejection
;
;401 Data of Service
;Date can be -90 to +90 of current date.
S TDATA=TDATA_$$DTF1^ABSPECFM(E1DATE)
;
;110 Software Vendor/Certification ID
S TDATA=TDATA_$$ANFF^ABSPECFM(" ",10) ;real?? don't know yet
;S TDATA=TDATA_$$ANFF^ABSPECFM("TROOPELIG",10) ;NDC's testing system
;
;add segment and field separators
S TDATA=TDATA_SS_FS
;
Q
PATIENT ; Patient Seg
;
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 info
;
;preset field 111 to AM01 (seg id)
S TDATA=TDATA_"AM01"_FS
;
;304 DOB - try Medicare DOB first
; else use patient DOB
;Next line for testing ONLY Don't forget to comment it back out....and uncomment the line below it.
S ABSP304=$$DTF1^ABSPECFM($$GET1^DIQ(9000003,E1PIEN_",",2102,"I")) ;RLT - Patch 24
;IHS/OIT/Pieran/RCS - Patch 42;DOB was not taken from patient when DOB="00000000"
;S:ABSP304="" ABSP304=$$DTF1^ABSPECFM($P(XDATA,U,3)) ;RLT - Patch 24
S:'ABSP304 ABSP304=$$DTF1^ABSPECFM($P(XDATA,U,3)) ;RCS - Patch42;RLT - Patch 24
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_";"
;
;patient name - try Medicare name first
; else use patient name
;S ABSPNAM=$$GET1^DIQ(9000003,E1PIEN_",",.01,"E")
S ABSPNAM=$$GET1^DIQ(9000003,E1PIEN_",",2101,"E") ;RLT - Patch 24
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 ; Insurance Seg
;
N ABSP302,ABSP301,ABSPCID
;
S TDATA=TDATA_"AM04"_FS
;
;302 Cardholder ID - medicare cardholder
; id, else use last 4 of SSN
S ABSP302=$$GET1^DIQ(9000003,E1PIEN_",",.03,"E")
S ABSP302S=$$GET1^DIQ(9000003,E1PIEN_",",.04,"E")
S:ABSP302'="" ABSP302=ABSP302_ABSP302S
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
;COMMENT THE THREE LINES BELOW BACK OUT WHEN DONE TESTING
;S ABSP301=$$ANFF^ABSPECFM("TATA",10)
;S TDATA=TDATA_"C1"_ABSP301
;S DR=DR_"301////"_ABSP301
;
Q
RAWTRANS ; Raw trans 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^ABSPOSE2",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
Q
DISPLAY(E1IEN) ;EP - E1 result
;
N ABSPPNAM,ABSP112,ABSP504,ABSP526,COVER
N ABSP503,ABSPCUT,ABSPSTR,ABSP03,ABSP302
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 ABSP302=$$GET1^DIQ(9002313.7,E1IEN_",",302,"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
I ABSPINS["&" D DISPLAY^ABSPOSE1(E1IEN) Q
D PARSE504(ABSP504,.COVER)
D PARSE526(ABSP526,.COVER)
;
W !,"On: ",ABSP03
W !,"Patient Name: ",ABSPPNAM
W !,"Medicare ID: ",ABSP302
W !,"Status: ",ABSP112
W !,"Authorization #: ",ABSP503
;
I ABSP112'="A" D
. W !,"Result:"
. ;
. N LINECNT
. S LINECNT=1
. ;
. I $D(ABSP504) D
.. S ABSPSTR=1
.. I $L(ABSP504)>50 D
... S LINECNT=$L(ABSP504)\50
... S:LINECNT#50'=0 LINECNT=LINECNT+1
.. F ABSPCUT=1:1:LINECNT D
... 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
... S LINECNT=$L(ABSP526)\50
... S:LINECNT#50'=0 LINECNT=LINECNT+1
.. F ABSPCUT=1:1:LINECNT D
... W ?18,$E(ABSP526,ABSPSTR,ABSPSTR+50),!," "
... S ABSPSTR=ABSPSTR+50
;
I ABSP112="A" D
. W !!,"PATIENT INFORMATION"
. W !," LAST NAME : ",COVER(1,"LAST NAME")
. W !," FIRST NAME : ",COVER(1,"FIRST NAME")
. W !," DOB : ",$$DATE(COVER(1,"DOB"))
. W !!,"MEDICARE D INFORMATION"
. W !," Insurance Level : ",COVER(1,"INS LVL")
. W !," BIN : ",COVER(1,"BIN")
. W !," PCN : ",COVER(1,"PCN")
. W !," GROUP : ",COVER(1,"GROUP")
. W !," CARDHOLDER ID : ",COVER(1,"CARD ID")
. W !," PERSON CODE : ",COVER(1,"PERSON CD")
. W !," PHONE NUMBER : ",COVER(1,"PHONE #")
. W !," CONTRACT ID : ",COVER(1,"CONTRACT ID")
. W !," RX BENEFIT PLAN : ",COVER(1,"PBP")
. W !," EFFECTIVE DATE : ",$$DATE(COVER(1,"EFF DATE"))
. W !," TERMINATION DATE: ",$$DATE(COVER(1,"TRM DATE"))
. W !," LOW-INCOME COST : ",COVER(1,"LICS")
. W !," FORMULARY ID : ",COVER(1,"FORMULARY ID")
. W !!,"FUTURE MEDICARE PART D INFORMATION:"
. W !," EFFECTIVE DATE : ",$$DATE(COVER(1,"FUTURE EFF DATE"))
. W !," TERMINATION DATE: ",$$DATE(COVER(1,"FUTURE TRM DATE"))
. ;
. W !!,"OTHER COVERAGE INFORMATION"
. W !,"Secondary Coverage"
. I $TR(COVER(2,"DISPCHK")," ","")="" D
.. W !," None"
. E D
.. W !," Insurance Level : ",COVER(2,"INS LVL")
.. W !," BIN : ",COVER(2,"BIN")
.. W !," PCN : ",COVER(2,"PCN")
.. W !," GROUP : ",COVER(2,"GROUP")
.. W !," CARDHOLDER ID : ",COVER(2,"CARD ID")
.. W !," PERSON CODE : ",COVER(2,"PERSON CD")
.. W !," RELATIONSHIP CD : ",COVER(2,"RELATIONSHIP CD")
.. W !," PHONE NUMBER : ",COVER(2,"PHONE #")
. ;
. W !,"Tertiary Coverage"
. I $TR(COVER(3,"DISPCHK")," ","")="" D
.. W !," None"
. E D
.. W !!," Insurance Level : ",COVER(3,"INS LVL")
.. W !," BIN : ",COVER(3,"BIN")
.. W !," PCN : ",COVER(3,"PCN")
.. W !," GROUP : ",COVER(3,"GROUP")
.. W !," CARDHOLDER ID : ",COVER(3,"CARD ID")
.. W !," PERSON CODE : ",COVER(3,"PERSON CD")
.. W !," RELATIONSHIP CD : ",COVER(3,"RELATIONSHIP CD")
.. W !," PHONE NUMBER : ",COVER(3,"PHONE #")
;
Q
;
PARSE504(INS504,COVER) ;
;
S COVER(1,"LAST NAME")=$E(INS504,4,16)
S COVER(1,"FIRST NAME")=$E(INS504,20,29)
S COVER(1,"DOB")=$E(INS504,33,40)
S COVER(1,"INS LVL")=$E(INS504,44,44)
S COVER(1,"BIN")=$E(INS504,48,53)
S COVER(1,"PCN")=$E(INS504,57,66)
S COVER(1,"GROUP")=$E(INS504,70,84)
S COVER(1,"CARD ID")=$E(INS504,88,107)
S COVER(1,"PERSON CD")=$E(INS504,111,113)
S COVER(1,"PHONE #")=$E(INS504,117,126)
S COVER(1,"CONTRACT ID")=$E(INS504,130,135)
S COVER(1,"PBP")=$E(INS504,139,141)
S COVER(1,"EFF DATE")=$E(INS504,145,152)
S COVER(1,"TRM DATE")=$E(INS504,156,163)
S COVER(1,"LICS")=$E(INS504,167,167)
S COVER(1,"FORMULARY ID")=$E(INS504,171,178)
S COVER(1,"FUTURE EFF DATE")=$E(INS504,182,189)
S COVER(1,"FUTURE TRM DATE")=$E(INS504,193,200)
;
Q
PARSE526(INS526,COVER) ;
;
S COVER(2,"INS LVL")=$E(INS526,4,4)
S COVER(2,"BIN")=$E(INS526,8,13)
S COVER(2,"PCN")=$E(INS526,17,26)
S COVER(2,"GROUP")=$E(INS526,30,44)
S COVER(2,"CARD ID")=$E(INS526,48,67)
S COVER(2,"PERSON CD")=$E(INS526,71,73)
S COVER(2,"RELATIONSHIP CD")=$E(INS526,77,77)
S COVER(2,"PHONE #")=$E(INS526,81,90)
S COVER(2,"DISPCHK")=COVER(2,"INS LVL")_COVER(2,"BIN")_COVER(2,"PCN")_COVER(2,"GROUP")_COVER(2,"CARD ID")_COVER(2,"PERSON CD")_COVER(2,"RELATIONSHIP CD")_COVER(2,"PHONE #")
;
S COVER(3,"INS LVL")=$E(INS526,94,94)
S COVER(3,"BIN")=$E(INS526,98,103)
S COVER(3,"PCN")=$E(INS526,107,116)
S COVER(3,"GROUP")=$E(INS526,120,134)
S COVER(3,"CARD ID")=$E(INS526,138,157)
S COVER(3,"PERSON CD")=$E(INS526,161,163)
S COVER(3,"RELATIONSHIP CD")=$E(INS526,167,167)
S COVER(3,"PHONE #")=$E(INS526,171,180)
S COVER(3,"DISPCHK")=COVER(3,"INS LVL")_COVER(3,"BIN")_COVER(3,"PCN")_COVER(3,"GROUP")_COVER(3,"CARD ID")_COVER(3,"PERSON CD")_COVER(3,"RELATIONSHIP CD")_COVER(3,"PHONE #")
;
Q
DATE(CCYYMMDD) ;
I $TR(CCYYMMDD," ","")="" Q ""
D ^XBFMK ;kill FileMan variables
S Y=CCYYMMDD-17000000
D DD^%DT
Q Y
ABSPOSE2 ; IHS/SD/lwj - E1 generation routine ; [ 10/24/2005 10:09:07 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**21,24,40,42,48**;JUN 21, 2001;Build 38
+2 ;
+3 ;IHS/SD/RLT - 05/22/07 - Patch 21
+4 ; Enhanced E1 - modified version of ABSPOSE1
+5 ; See comments in ABSPOSE1 for further E1 details
+6 ;
+7 ;IHS/SD/RLT - 02/13/08 - Patch 24
+8 ; Fixed Medicare name and DOB lookup (IM27373)
+9 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,E1DATE
+2 ;
+3 SET POP=1
+4 ; get 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 ; get pharmacy
+11 ;ien ^ABSP(9002313.56
SET E1PHARM=$$GETPHARM
+12 IF E1PHARM<1
QUIT
+13 ;
+14 ; get ^ABSPE rec
+15 ;ien ^ABSPE
SET E1IEN=$$GETABSPE
+16 ;had prev one, didn't want new one
IF E1IEN<1
QUIT
+17 ;
+18 ;E1DATE - service date sent in header
SET E1DATE=$$GETDATE
+19 IF E1DATE=""
QUIT
+20 ;
+21 ; create transmission
+22 DO CRTE1
+23 USE $PRINCIPAL
WRITE !!,"Transmitting eligibility check, please stand by.....",!!
+24 ;send trans
DO SEND^ABSPOSAE(TDATA,E1IEN)
+25 SET POP=0
+26 ;
+27 QUIT
GETPAT() ; Prompt for patient.
+1 ;
+2 NEW ABSPDUZ2,PATDONE,Y,DIC
+3 NEW X
+4 SET X=""
+5 ;
+6 ;set to one when 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 IF (($GET(DUOUT))!($GET(DTOUT))!(Y>0)!(X=""))
SET PATDONE=1
End DoDot:1
IF PATDONE
QUIT
+18 KILL DIC
+19 SET DUZ(2)=ABSPDUZ2
+20 ;
+21 QUIT Y
GETPHARM() ; Prompt for pharmacy.
+1 ;
+2 NEW PHARM,HLDPHARM,Y,PDONE,PHMCNT,DIC
+3 ;
+4 SET (PHMCNT,PDONE,PHARM,Y)=0
+5 ;
+6 FOR
SET PHARM=$ORDER(^ABSP(9002313.56,PHARM))
IF '+PHARM
QUIT
Begin DoDot:1
+7 SET PHMCNT=PHMCNT+1
+8 IF PHMCNT=1
SET HLDPHARM=PHARM
End DoDot:1
+9 IF PHMCNT=1
QUIT HLDPHARM
+10 ;
+11 WRITE !!
+12 SET DIC=9002313.56
SET DIC(0)="AEMQZ"
+13 SET DIC("B")=$PIECE($GET(^ABSP(9002313.56,HLDPHARM,0)),U)
+14 SET DIC("A")="Please specify the pharmacy: "
+15 FOR
Begin DoDot:1
+16 DO ^DIC
+17 USE $PRINCIPAL
WRITE !
+18 IF (($GET(DUOUT))!($GET(DTOUT))!(Y>0))
SET PDONE=1
End DoDot:1
IF PDONE
QUIT
+19 ;
+20 QUIT +Y
GETDATE() ; Prompt for service date.
+1 NEW CURDISP,X1,X2,BEGDT,ENDDT,E1DT
+2 ;
+3 SET Y=DT
+4 DO DD^%DT
+5 SET CURDISP=Y
+6 ;
+7 SET X1=DT
SET X2=-90
+8 DO C^%DTC
+9 SET BEGDT=X
+10 SET Y=X
+11 DO DD^%DT
+12 SET BEGDISP=Y
+13 ;
+14 SET X1=DT
SET X2=+90
+15 DO C^%DTC
+16 SET ENDDT=X
+17 SET Y=X
+18 DO DD^%DT
+19 SET ENDDISP=Y
+20 ;
+21 WRITE !,"Accept the default current date of ",CURDISP," or"
+22 WRITE !,"Enter a date between ",BEGDISP," and ",ENDDISP,!
+23 SET E1DT=$$DATE^ABSPOSU1("Enter Service Date: ",DT,0,BEGDT,ENDDT,"EX")
+24 IF E1DT="^"!(E1DT="^^")!(E1DT=-1)
SET E1DT=""
+25 QUIT E1DT
+26 ;
GETABSPE() ; If E1 previously sent, find it and prompt to send again.
+1 ; If doesn't exist, create new one.
+2 ;
+3 NEW X,DIC,DLAYGO,Y,NEWE1,CRTNWE1,E1IEN
+4 SET DIC="^ABSPE("
SET DIC(0)="XZ"
+5 SET X="`"_E1PIEN
+6 SET (NEWE1,CRTNWE1)=0
+7 ;
+8 ;look for old E1
+9 DO ^DIC
+10 KILL DIC
+11 SET E1IEN=+Y
+12 ;doesn't exist - add
IF E1IEN<1
SET CRTNWE1=1
+13 ;exist - send again?
IF E1IEN>0
SET NEWE1=$$PRMPT(E1IEN)
+14 ;
+15 ; Yes, send again - delete old entry
+16 IF NEWE1
Begin DoDot:1
+17 NEW DIK,DA
+18 SET DIK="^ABSPE("
+19 SET DA=E1IEN
+20 DO ^DIK
+21 KILL DIK,DA
+22 SET CRTNWE1=1
End DoDot:1
+23 ;
+24 ; create new entry
+25 IF CRTNWE1
Begin DoDot:1
+26 SET DIC="^ABSPE("
+27 SET X="`"_E1PIEN
+28 SET DLAYGO=9002313.7
SET DIC(0)="LXZ"
+29 DO ^DIC
End DoDot:1
+30 ;
+31 QUIT +Y
+32 ;
PRMPT(E1IEN) ;Display previous response and prompt to send again.
+1 ;
+2 NEW RESULT,DIR,STATUS
+3 ;
+4 ; if previous result an error, send new E1
+5 SET RESULT=$$GET1^DIQ(9002313.7,E1IEN_",",9999999,"E")
+6 IF RESULT'=""
QUIT 1
+7 ;
+8 ; if status rejected, send new E1
+9 SET STATUS=$$GET1^DIQ(9002313.7,E1IEN_",",112,"E")
+10 IF STATUS="R"
QUIT 1
+11 ;
+12 ;
+13 USE $PRINCIPAL
+14 WRITE !!!,"A check was previously submitted for this patient: "
+15 DO DISPLAY(E1IEN)
+16 ;
+17 SET DIR("A")="Would you like to send a new eligibility check? "
+18 ;S DIR("B")="Y" ;IHS/OIT/CNI/SCR patch 40 change default answer to "N"
+19 SET DIR("B")="N"
+20 SET DIR(0)="YAO"
+21 DO ^DIR
+22 ;
+23 QUIT Y
CRTE1 ; Creates transmission record, updates ^ABSPE.
+1 ;
+2 NEW FS,SS
+3 NEW DIE,DA,DR
+4 ;N TDATA
+5 ;
+6 SET TDATA=""
+7 SET DIE="^ABSPE("
SET DA=E1IEN
+8 ;field and segment separators
SET FS=$CHAR(28)
SET SS=$CHAR(30)
+9 ;
+10 DO HEADER
+11 DO PATIENT
+12 DO INSURER
+13 ;
+14 ;update ^ABSPE with the patient and insurance information
+15 ;
+16 DO ^DIE
+17 ;
+18 ;update ^ABSPE with raw message
+19 DO RAWTRANS
+20 ;
+21 QUIT
+22 ;
+1 ;
+2 NEW XDATA
+3 ;
+4 ;E1PHARM set from call to GETPHARM
SET XDATA=$GET(^ABSP(9002313.56,E1PHARM,0))
+5 ;
+6 ;101 BIN (Emdeon plan # hard coded to 006015) + 102 Version (always 51) +
+7 ;103 Trans Code (always E1)
+8 ;Troop extended elig response
SET TDATA="00102451E1"
+9 ; IHS/OIT/CASSevern/Pieran/RAN 10/31/2011 Patch 42 Allow us to send D.0 version of Troop Eligibility
+10 IF $DATA(^ABSP(9002313.99,1,"ABSPICNV"))
SET TDATA="011727D0E1"
+11 ;
+12 ;104 Processor control number (Emdeon terminal id for sending pharmacy)
+13 SET TDATA=TDATA_$SELECT($DATA(^ABSP(9002313.99,1,"ABSPICNV")):2222222222,1:$TRANSLATE($JUSTIFY($PIECE(XDATA,U,6),10)," ","0"))
+14 ;109 Transaction Count (1 for the E1)+202 Service Prov ID Qual (always 07)
+15 SET TDATA=TDATA_107
+16 ;
+17 ;201 Service Provider ID
+18 ;NCPDP number
SET TDATA=TDATA_$$ANFF^ABSPECFM($PIECE(XDATA,U,2),15)
+19 ;S TDATA=TDATA_$$ANFF^ABSPECFM("1234567",15) ;forces rejection
+20 ;
+21 ;401 Data of Service
+22 ;Date can be -90 to +90 of current date.
+23 SET TDATA=TDATA_$$DTF1^ABSPECFM(E1DATE)
+24 ;
+25 ;110 Software Vendor/Certification ID
+26 ;real?? don't know yet
SET TDATA=TDATA_$$ANFF^ABSPECFM(" ",10)
+27 ;S TDATA=TDATA_$$ANFF^ABSPECFM("TROOPELIG",10) ;NDC's testing system
+28 ;
+29 ;add segment and field separators
+30 SET TDATA=TDATA_SS_FS
+31 ;
+32 QUIT
PATIENT ; Patient Seg
+1 ;
+2 NEW ABSP304,ABSP305,ABSP310,ABSP311,ABSP332,ABSP323,ABSP324
+3 NEW ABSP325,ABSP326,XDATA,XDATA11,ABSPNAM
+4 ;
+5 NEW STCODE
+6 ;
+7 ;patient data
SET XDATA=$GET(^DPT(E1PIEN,0))
+8 ;address info
SET XDATA11=$GET(^DPT(E1PIEN,.11))
+9 ;
+10 ;preset field 111 to AM01 (seg id)
+11 SET TDATA=TDATA_"AM01"_FS
+12 ;
+13 ;304 DOB - try Medicare DOB first
+14 ; else use patient DOB
+15 ;Next line for testing ONLY Don't forget to comment it back out....and uncomment the line below it.
+16 ;RLT - Patch 24
SET ABSP304=$$DTF1^ABSPECFM($$GET1^DIQ(9000003,E1PIEN_",",2102,"I"))
+17 ;IHS/OIT/Pieran/RCS - Patch 42;DOB was not taken from patient when DOB="00000000"
+18 ;S:ABSP304="" ABSP304=$$DTF1^ABSPECFM($P(XDATA,U,3)) ;RLT - Patch 24
+19 ;RCS - Patch42;RLT - Patch 24
IF 'ABSP304
SET ABSP304=$$DTF1^ABSPECFM($PIECE(XDATA,U,3))
+20 SET TDATA=TDATA_"C4"_ABSP304_FS
+21 SET DR="304////"_ABSP304_";"
+22 ;
+23 ;305 Patient Gender
+24 SET ABSP305=$EXTRACT($PIECE(XDATA,U,2),1,1)
+25 SET ABSP305=$SELECT(ABSP305="M":"1",ABSP305="F":"2",1:"0")
+26 SET ABSP305=$$NFF^ABSPECFM(ABSP305,1)
+27 SET TDATA=TDATA_"C5"_ABSP305_FS
+28 SET DR=DR_"305////"_ABSP305_";"
+29 ;
+30 ;patient name - try Medicare name first
+31 ; else use patient name
+32 ;S ABSPNAM=$$GET1^DIQ(9000003,E1PIEN_",",.01,"E")
+33 ;RLT - Patch 24
SET ABSPNAM=$$GET1^DIQ(9000003,E1PIEN_",",2101,"E")
+34 IF ABSPNAM=""
SET ABSPNAM=$PIECE(XDATA,U)
+35 ;
+36 ;310 Patient First Name
+37 SET ABSP310=$$ANFF^ABSPECFM($PIECE($PIECE(ABSPNAM,",",2)," "),12)
+38 SET TDATA=TDATA_"CA"_ABSP310_FS
+39 SET DR=DR_"310////"_ABSP310_";"
+40 ;
+41 ;311 Patient Last Name
+42 SET ABSP311=$$ANFF^ABSPECFM($PIECE(ABSPNAM,",",1),15)
+43 SET TDATA=TDATA_"CB"_ABSP311_FS
+44 SET DR=DR_"311////"_ABSP311_";"
+45 ;
+46 ;322 Patient Street Address - not used yet
+47 ;S ABSP322=$$ANFF^ABSPECFM($P(XDATA11,U),30)
+48 ;S TDATA=TDATA_"CM"_ABSP322_FS
+49 ;S DR=DR_"322////"_ABSP322_";"
+50 ;
+51 ;323 Patient City Address - not used yet
+52 ;S ABSP323=$$ANFF^ABSPECFM($P(XDATA11,U,4),20)
+53 ;S TDATA=TDATA_"CN"_ABSP323_FS
+54 ;S DR=DR_"323////"_ABSP323_";"
+55 ;
+56 ;324 Patient State/Province Address - not used yet
+57 ;S ABSP324=""
+58 ;S STCODE=$P(XDATA11,U,5)
+59 ;S:STCODE'="" ABSP324=$P($G(^DIC(5,STCODE,0)),U,2)
+60 ;S ABSP324=$$ANFF^ABSPECFM(ABSP324,2)
+61 ;S TDATA=TDATA_"CO"_ABSP324_FS
+62 ;S DR=DR_"324////"_ABSP324_";"
+63 ;
+64 ;325 Patient Zip/Postal Zone - currently last field
+65 ; so the segment separator must be there
+66 SET ABSP325=$$ANFF^ABSPECFM($PIECE(XDATA11,U,6),15)
+67 SET TDATA=TDATA_"CP"_ABSP325_SS_FS
+68 SET DR=DR_"325////"_ABSP325_";"
+69 ;
+70 ;326 Patient Phone Number - not used yet
+71 ; if they want this, remove the segment separator from
+72 ; the zip code
+73 ;S ABSP326=$TR($$GET1^DIQ(2,E1PIEN_",",.131,"E"),"()-")
+74 ;S ABSP326=$$NFF^ABSPECFM(ABSP326,10)
+75 ;S TDATA=TDATA_"CQ"_ABSP326_SS_FS
+76 ;S DR=DR_"326////"_ABSP326_";"
+77 ;
+78 QUIT
INSURER ; Insurance Seg
+1 ;
+2 NEW ABSP302,ABSP301,ABSPCID
+3 ;
+4 SET TDATA=TDATA_"AM04"_FS
+5 ;
+6 ;302 Cardholder ID - medicare cardholder
+7 ; id, else use last 4 of SSN
+8 SET ABSP302=$$GET1^DIQ(9000003,E1PIEN_",",.03,"E")
+9 SET ABSP302S=$$GET1^DIQ(9000003,E1PIEN_",",.04,"E")
+10 IF ABSP302'=""
SET ABSP302=ABSP302_ABSP302S
+11 IF ABSP302=""
Begin DoDot:1
+12 SET ABSP302=$$GET1^DIQ(2,E1PIEN_",",.09,"E")
+13 SET ABSP302=$EXTRACT(ABSP302,$LENGTH(ABSP302)-3,$LENGTH(ABSP302))
End DoDot:1
+14 ;
+15 SET ABSP302=$TRANSLATE(ABSP302,"-/.","")
+16 SET ABSP302=$$ANFF^ABSPECFM(ABSP302,20)
+17 SET TDATA=TDATA_"C2"_ABSP302
+18 ;S TDATA=TDATA_"C2"_ABSP302_FS ; Bart's system
+19 SET DR=DR_"302////"_ABSP302
+20 ;
+21 ;301 group number - just for testing
+22 ; Bart's system - don't know if this fld
+23 ; will be needed for live - put the fld
+24 ; separator on 302 (above) if 301 is needed
+25 ;COMMENT THE THREE LINES BELOW BACK OUT WHEN DONE TESTING
+26 ;S ABSP301=$$ANFF^ABSPECFM("TATA",10)
+27 ;S TDATA=TDATA_"C1"_ABSP301
+28 ;S DR=DR_"301////"_ABSP301
+29 ;
+30 QUIT
RAWTRANS ; Raw trans 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^ABSPOSE2",.ZERR)
+7 ;
+8 QUIT
DISPLAY(E1IEN) ;EP - E1 result
+1 ;
+2 NEW ABSPPNAM,ABSP112,ABSP504,ABSP526,COVER
+3 NEW ABSP503,ABSPCUT,ABSPSTR,ABSP03,ABSP302
+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 ABSP302=$$GET1^DIQ(9002313.7,E1IEN_",",302,"E")
+10 SET ABSP503=$$GET1^DIQ(9002313.7,E1IEN_",",503,"E")
+11 SET ABSP504=$$GET1^DIQ(9002313.7,E1IEN_",",504,"E")
+12 SET ABSP526=$$GET1^DIQ(9002313.7,E1IEN_",",526,"E")
+13 SET ABSPINS=ABSP504_ABSP526
+14 IF ABSPINS["&"
DO DISPLAY^ABSPOSE1(E1IEN)
QUIT
+15 DO PARSE504(ABSP504,.COVER)
+16 DO PARSE526(ABSP526,.COVER)
+17 ;
+18 WRITE !,"On: ",ABSP03
+19 WRITE !,"Patient Name: ",ABSPPNAM
+20 WRITE !,"Medicare ID: ",ABSP302
+21 WRITE !,"Status: ",ABSP112
+22 WRITE !,"Authorization #: ",ABSP503
+23 ;
+24 IF ABSP112'="A"
Begin DoDot:1
+25 WRITE !,"Result:"
+26 ;
+27 NEW LINECNT
+28 SET LINECNT=1
+29 ;
+30 IF $DATA(ABSP504)
Begin DoDot:2
+31 SET ABSPSTR=1
+32 IF $LENGTH(ABSP504)>50
Begin DoDot:3
+33 SET LINECNT=$LENGTH(ABSP504)\50
+34 IF LINECNT#50'=0
SET LINECNT=LINECNT+1
End DoDot:3
+35 FOR ABSPCUT=1:1:LINECNT
Begin DoDot:3
+36 WRITE ?18,$EXTRACT(ABSP504,ABSPSTR,ABSPSTR+50),!," "
+37 SET ABSPSTR=ABSPSTR+50
End DoDot:3
End DoDot:2
+38 ;
+39 SET LINECNT=1
+40 ;
+41 IF $DATA(ABSP526)
Begin DoDot:2
+42 SET ABSPSTR=1
+43 IF $LENGTH(ABSP526)>50
Begin DoDot:3
+44 SET LINECNT=$LENGTH(ABSP526)\50
+45 IF LINECNT#50'=0
SET LINECNT=LINECNT+1
End DoDot:3
+46 FOR ABSPCUT=1:1:LINECNT
Begin DoDot:3
+47 WRITE ?18,$EXTRACT(ABSP526,ABSPSTR,ABSPSTR+50),!," "
+48 SET ABSPSTR=ABSPSTR+50
End DoDot:3
End DoDot:2
End DoDot:1
+49 ;
+50 IF ABSP112="A"
Begin DoDot:1
+51 WRITE !!,"PATIENT INFORMATION"
+52 WRITE !," LAST NAME : ",COVER(1,"LAST NAME")
+53 WRITE !," FIRST NAME : ",COVER(1,"FIRST NAME")
+54 WRITE !," DOB : ",$$DATE(COVER(1,"DOB"))
+55 WRITE !!,"MEDICARE D INFORMATION"
+56 WRITE !," Insurance Level : ",COVER(1,"INS LVL")
+57 WRITE !," BIN : ",COVER(1,"BIN")
+58 WRITE !," PCN : ",COVER(1,"PCN")
+59 WRITE !," GROUP : ",COVER(1,"GROUP")
+60 WRITE !," CARDHOLDER ID : ",COVER(1,"CARD ID")
+61 WRITE !," PERSON CODE : ",COVER(1,"PERSON CD")
+62 WRITE !," PHONE NUMBER : ",COVER(1,"PHONE #")
+63 WRITE !," CONTRACT ID : ",COVER(1,"CONTRACT ID")
+64 WRITE !," RX BENEFIT PLAN : ",COVER(1,"PBP")
+65 WRITE !," EFFECTIVE DATE : ",$$DATE(COVER(1,"EFF DATE"))
+66 WRITE !," TERMINATION DATE: ",$$DATE(COVER(1,"TRM DATE"))
+67 WRITE !," LOW-INCOME COST : ",COVER(1,"LICS")
+68 WRITE !," FORMULARY ID : ",COVER(1,"FORMULARY ID")
+69 WRITE !!,"FUTURE MEDICARE PART D INFORMATION:"
+70 WRITE !," EFFECTIVE DATE : ",$$DATE(COVER(1,"FUTURE EFF DATE"))
+71 WRITE !," TERMINATION DATE: ",$$DATE(COVER(1,"FUTURE TRM DATE"))
+72 ;
+73 WRITE !!,"OTHER COVERAGE INFORMATION"
+74 WRITE !,"Secondary Coverage"
+75 IF $TRANSLATE(COVER(2,"DISPCHK")," ","")=""
Begin DoDot:2
+76 WRITE !," None"
End DoDot:2
+77 IF '$TEST
Begin DoDot:2
+78 WRITE !," Insurance Level : ",COVER(2,"INS LVL")
+79 WRITE !," BIN : ",COVER(2,"BIN")
+80 WRITE !," PCN : ",COVER(2,"PCN")
+81 WRITE !," GROUP : ",COVER(2,"GROUP")
+82 WRITE !," CARDHOLDER ID : ",COVER(2,"CARD ID")
+83 WRITE !," PERSON CODE : ",COVER(2,"PERSON CD")
+84 WRITE !," RELATIONSHIP CD : ",COVER(2,"RELATIONSHIP CD")
+85 WRITE !," PHONE NUMBER : ",COVER(2,"PHONE #")
End DoDot:2
+86 ;
+87 WRITE !,"Tertiary Coverage"
+88 IF $TRANSLATE(COVER(3,"DISPCHK")," ","")=""
Begin DoDot:2
+89 WRITE !," None"
End DoDot:2
+90 IF '$TEST
Begin DoDot:2
+91 WRITE !!," Insurance Level : ",COVER(3,"INS LVL")
+92 WRITE !," BIN : ",COVER(3,"BIN")
+93 WRITE !," PCN : ",COVER(3,"PCN")
+94 WRITE !," GROUP : ",COVER(3,"GROUP")
+95 WRITE !," CARDHOLDER ID : ",COVER(3,"CARD ID")
+96 WRITE !," PERSON CODE : ",COVER(3,"PERSON CD")
+97 WRITE !," RELATIONSHIP CD : ",COVER(3,"RELATIONSHIP CD")
+98 WRITE !," PHONE NUMBER : ",COVER(3,"PHONE #")
End DoDot:2
End DoDot:1
+99 ;
+100 QUIT
+101 ;
PARSE504(INS504,COVER) ;
+1 ;
+2 SET COVER(1,"LAST NAME")=$EXTRACT(INS504,4,16)
+3 SET COVER(1,"FIRST NAME")=$EXTRACT(INS504,20,29)
+4 SET COVER(1,"DOB")=$EXTRACT(INS504,33,40)
+5 SET COVER(1,"INS LVL")=$EXTRACT(INS504,44,44)
+6 SET COVER(1,"BIN")=$EXTRACT(INS504,48,53)
+7 SET COVER(1,"PCN")=$EXTRACT(INS504,57,66)
+8 SET COVER(1,"GROUP")=$EXTRACT(INS504,70,84)
+9 SET COVER(1,"CARD ID")=$EXTRACT(INS504,88,107)
+10 SET COVER(1,"PERSON CD")=$EXTRACT(INS504,111,113)
+11 SET COVER(1,"PHONE #")=$EXTRACT(INS504,117,126)
+12 SET COVER(1,"CONTRACT ID")=$EXTRACT(INS504,130,135)
+13 SET COVER(1,"PBP")=$EXTRACT(INS504,139,141)
+14 SET COVER(1,"EFF DATE")=$EXTRACT(INS504,145,152)
+15 SET COVER(1,"TRM DATE")=$EXTRACT(INS504,156,163)
+16 SET COVER(1,"LICS")=$EXTRACT(INS504,167,167)
+17 SET COVER(1,"FORMULARY ID")=$EXTRACT(INS504,171,178)
+18 SET COVER(1,"FUTURE EFF DATE")=$EXTRACT(INS504,182,189)
+19 SET COVER(1,"FUTURE TRM DATE")=$EXTRACT(INS504,193,200)
+20 ;
+21 QUIT
PARSE526(INS526,COVER) ;
+1 ;
+2 SET COVER(2,"INS LVL")=$EXTRACT(INS526,4,4)
+3 SET COVER(2,"BIN")=$EXTRACT(INS526,8,13)
+4 SET COVER(2,"PCN")=$EXTRACT(INS526,17,26)
+5 SET COVER(2,"GROUP")=$EXTRACT(INS526,30,44)
+6 SET COVER(2,"CARD ID")=$EXTRACT(INS526,48,67)
+7 SET COVER(2,"PERSON CD")=$EXTRACT(INS526,71,73)
+8 SET COVER(2,"RELATIONSHIP CD")=$EXTRACT(INS526,77,77)
+9 SET COVER(2,"PHONE #")=$EXTRACT(INS526,81,90)
+10 SET COVER(2,"DISPCHK")=COVER(2,"INS LVL")_COVER(2,"BIN")_COVER(2,"PCN")_COVER(2,"GROUP")_COVER(2,"CARD ID")_COVER(2,"PERSON CD")_COVER(2,"RELATIONSHIP CD")_COVER(2,"PHONE #")
+11 ;
+12 SET COVER(3,"INS LVL")=$EXTRACT(INS526,94,94)
+13 SET COVER(3,"BIN")=$EXTRACT(INS526,98,103)
+14 SET COVER(3,"PCN")=$EXTRACT(INS526,107,116)
+15 SET COVER(3,"GROUP")=$EXTRACT(INS526,120,134)
+16 SET COVER(3,"CARD ID")=$EXTRACT(INS526,138,157)
+17 SET COVER(3,"PERSON CD")=$EXTRACT(INS526,161,163)
+18 SET COVER(3,"RELATIONSHIP CD")=$EXTRACT(INS526,167,167)
+19 SET COVER(3,"PHONE #")=$EXTRACT(INS526,171,180)
+20 SET COVER(3,"DISPCHK")=COVER(3,"INS LVL")_COVER(3,"BIN")_COVER(3,"PCN")_COVER(3,"GROUP")_COVER(3,"CARD ID")_COVER(3,"PERSON CD")_COVER(3,"RELATIONSHIP CD")_COVER(3,"PHONE #")
+21 ;
+22 QUIT
DATE(CCYYMMDD) ;
+1 IF $TRANSLATE(CCYYMMDD," ","")=""
QUIT ""
+2 ;kill FileMan variables
DO ^XBFMK
+3 SET Y=CCYYMMDD-17000000
+4 DO DD^%DT
+5 QUIT Y
