BPSELG ;ALB/DRF - ECME SCREEN ELIGIBILITY VERIFICATION SUBMIT ;8/13/10 21:14
;;1.0;E CLAIMS MGMT ENGINE;**10,11**;JUN 2004;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; reference to ^DIR supported by DBIA 10026
; references to FULL^VALM1 and PAUSE^VALM1 supported by DBIA 10016
; reference to $$FMTE^XLFDT supported by DBIA 10103
;
;ECME Eligibility Verification w/EDITS Protocol (Hidden) - Called by [BPS USER SCREEN]
;
RESED N BPSEL
;
I '$D(@(VALMAR)) G XRESED
D FULL^VALM1
;
;Select the claim to submit
W !,"Enter the line number for the claim to be submitted for Eligibility Verification"
S BPSEL=$$ASKLINE("Select item","Please select a SINGLE claim only when using the Eligibility action option.")
I BPSEL<1 S VALMBCK="R" G XRESED
;
;Attempt to submit the claim for eligibility
D DOSELCTD(BPSEL)
S VALMBCK="R"
;
XRESED Q
;
;Attempt to Edit and Submit Selected Claim for Eligibility
;
; Input Value -> BPRXI - Entry with ptr to BPS TRANSACTION file
;
; Return Value -> 0 - Claim was not submitted
; 1 - Claim was submitted
;
DOSELCTD(BPRXI) ;
N BP02,BP59,BPRSLT,BPCLTOT,BPDFN,BPDOSDT,BPOVRIEN,BPQ,BPRXIEN,BPRXR,BPSTATUS,BPSELG,BPPROMPT,BPPSNCD,BPRELCD,BPUPDFLG
S (BPQ)=""
S (BPCLTOT,BPUPDFLG,BPRSLT)=0
;
;Pull BPS TRANSACTION/BPS CLAIMS entries
S BP59=$P(BPRXI,U,4) I BP59="" W !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Eligibility Submission",! G XRES
S BP02=+$P($G(^BPST(BP59,0)),U,4) I 'BP02 W !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Eligibility Submission",! G XRES
;
;Write Form Feed
W @IOF
;
;Display selected claim and ask to submit
S BPDFN=+$P($G(^BPST(BP59,0)),U,6)
W !,"You've chosen to VERIFY Eligibility of the following prescription for "_$E($$PATNAME^BPSSCRU2(BPDFN),1,13)
W !,@VALMAR@(+$P(BPRXI,U,5),0)
S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
I BPQ'=1 S BPQ="^" G XRES
;
;Check to make sure claim can be Submitted for Eligibility
S BPRXIEN=$P(BP59,".")
S BPRXR=+$E($P(BP59,".",2),1,4)
S BPSTATUS=$P($$CLAIMST^BPSSCRU3(BP59),U)
I BPSTATUS'["E REJECTED" W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"is NOT Rejected and cannot be Submitted for Eligibility Verification",! G XRES
;
;Prompt for EDIT Information
S BPPROMPT=$$PROMPTS(BP02,.BPDOSDT,.BPRELCD,.BPPSNCD) I BPPROMPT=-1 G XRES
;
;Send eligibility verification
S BPSELG("PLAN")=$P($G(^BPST(BP59,10,1,0)),U,1) ;IEN to the GROUP INSURANCE PLAN (#355.3) file
S BPSELG("DOS")=BPDOSDT ;Date of Service entered by the user
S BPSELG("IEN")=+$P($G(^BPST(BP59,1)),U,11) ;Prescription, if available
S BPSELG("FILL NUMBER")=+$P($G(^BPST(BP59,1)),U,1) ;Fill Number, if available
S BPSELG("REL CODE")=BPRELCD
S BPSELG("PERSON CODE")=BPPSNCD
S BPRSLT=$$EN^BPSNCPD9(BPDFN,.BPSELG)
;
;Print Return Value Message
W !!
W $P(BPRSLT,U,2)
;
XRES ;
D PAUSE^VALM1
Q
;
; Input Values -> BP02 - The BPS CLAIMS entry
;
; Output Value -> BPQ - -1 - The user chose to quit
; "" - The user completed the EDITS
; BPDOSDT - Effective Date of Eligibility Verification transaction
; BPRELCD - Patient Relationship Code from file #9002313.19
; BPPSNCD - Person Code assigned by payer. 1 - 3 characters free text
;
PROMPTS(BP02,BPDOSDT,BPRELCD,BPPSNCD) ;
I '$G(BP02) S BPQ=-1 G XPROMPTS
N %,BP300,BPFDA,BPFLD,BPMED,BPMSG,BPQ,DIC,DIR,DIROUT,DTOUT,DUOUT,X,Y,DIRUT
S BPQ=""
;
;Pull Information from Claim
S BP300=$G(^BPSC(BP02,300))
S BPRELCD=$TR($E($P(BP300,U,6),3,99)," ")
S BPPSNCD=$TR($E($P(BP300,U,3),3,99)," ")
S BPDOSDT=$$DOSDATE^BPSSCRRS(BPRXIEN,BPRXR)
;
;Effective Date
S DIR(0)="DO",DIR("A")="Effective Date"
K DIR("?") S DIR("?")="Enter the effective date for the Eligibility Verification transaction"
S DIR("B")=$$FMTE^XLFDT(BPDOSDT,"5ZD")
D ^DIR
I $D(DTOUT)!$D(DUOUT) S BPQ=-1 G XPROMPTS
S BPDOSDT=Y
;
;Relationship Code
N X,DIC,Y
S DIC("B")=BPRELCD
S DIC(0)="QEAM",DIC=9002313.19,DIC("A")="Relationship Code: "
D ^DIC
;Check for "^" or timeout
I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y G XPROMPTS
S BPRELCD=$P(Y,U,2)
K X,DIC,Y
;
;Person Code
K DIR("?") S DIR(0)="FO^1:3",DIR("A")="Person Code",DIR("?")="Enter the Specific Person Code Assigned to the Patient by the Payer"
S DIR("B")=BPPSNCD
D ^DIR
I $D(DTOUT)!$D(DUOUT) S BPQ=-1 G XPROMPTS
S BPPSNCD=Y
;
;Ask to proceed
W ! S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
I BPQ'=1 S BPQ=-1 G XPROMPTS
;
XPROMPTS ;
Q BPQ
;
;Prompt User for Claim to Resubmit (w/EDITS)
;
; Input values -> BPROMPT - prompt string
; BPERRMES - the message to display when the user tries
; to make multi line selection (optional)
; Piece
;output values -> 1 - 1 = okay, <0 = errors, 0 = quit
; 2 - patient ien #2
; 3 - insurance ien #36
; 4 - ptr to #9002313.59
; 5 - 1st line for index(es) in LM "VALM" array
; 6 - patient's index
; 7 - claim's index
;
ASKLINE(BPROMPT,BPERRMES) ;
N BPRET,BPCNT
S BPRET="",BPCNT=0
F S BPRET=$$SELLINE^BPSSCRU4(BPROMPT,"C",VALMAR,"") Q:BPRET'<0 D
. I BPCNT<1 S BPCNT=BPCNT+1 W !
. E S BPCNT=0 D RE^VALM4
. I BPRET=-1 W "Invalid line number" ; (invalid Patient summary line)"
. I BPRET=-8 W $S($G(BPERRMES)]"":BPERRMES,1:" Invalid line number")
. I BPRET=-4 W "Invalid line number" ; (invalid RX line)"
. I BPRET=-2 W "Please select Patient's summary line."
. I BPRET=-3 W "Please specify RX line."
. I ",-1,-8,-4,-2,-3,"'[(","_BPRET_",") W "Incorrect format." ; Corrupted array (",BPRET,")"
Q BPRET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSELG 5922 printed Sep 23, 2025@19:27:07 Page 2
BPSELG ;ALB/DRF - ECME SCREEN ELIGIBILITY VERIFICATION SUBMIT ;8/13/10 21:14
+1 ;;1.0;E CLAIMS MGMT ENGINE;**10,11**;JUN 2004;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; reference to ^DIR supported by DBIA 10026
+5 ; references to FULL^VALM1 and PAUSE^VALM1 supported by DBIA 10016
+6 ; reference to $$FMTE^XLFDT supported by DBIA 10103
+7 ;
+8 ;ECME Eligibility Verification w/EDITS Protocol (Hidden) - Called by [BPS USER SCREEN]
+9 ;
RESED NEW BPSEL
+1 ;
+2 IF '$DATA(@(VALMAR))
GOTO XRESED
+3 DO FULL^VALM1
+4 ;
+5 ;Select the claim to submit
+6 WRITE !,"Enter the line number for the claim to be submitted for Eligibility Verification"
+7 SET BPSEL=$$ASKLINE("Select item","Please select a SINGLE claim only when using the Eligibility action option.")
+8 IF BPSEL<1
SET VALMBCK="R"
GOTO XRESED
+9 ;
+10 ;Attempt to submit the claim for eligibility
+11 DO DOSELCTD(BPSEL)
+12 SET VALMBCK="R"
+13 ;
XRESED QUIT
+1 ;
+2 ;Attempt to Edit and Submit Selected Claim for Eligibility
+3 ;
+4 ; Input Value -> BPRXI - Entry with ptr to BPS TRANSACTION file
+5 ;
+6 ; Return Value -> 0 - Claim was not submitted
+7 ; 1 - Claim was submitted
+8 ;
DOSELCTD(BPRXI) ;
+1 NEW BP02,BP59,BPRSLT,BPCLTOT,BPDFN,BPDOSDT,BPOVRIEN,BPQ,BPRXIEN,BPRXR,BPSTATUS,BPSELG,BPPROMPT,BPPSNCD,BPRELCD,BPUPDFLG
+2 SET (BPQ)=""
+3 SET (BPCLTOT,BPUPDFLG,BPRSLT)=0
+4 ;
+5 ;Pull BPS TRANSACTION/BPS CLAIMS entries
+6 SET BP59=$PIECE(BPRXI,U,4)
IF BP59=""
WRITE !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Eligibility Submission",!
GOTO XRES
+7 SET BP02=+$PIECE($GET(^BPST(BP59,0)),U,4)
IF 'BP02
WRITE !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Eligibility Submission",!
GOTO XRES
+8 ;
+9 ;Write Form Feed
+10 WRITE @IOF
+11 ;
+12 ;Display selected claim and ask to submit
+13 SET BPDFN=+$PIECE($GET(^BPST(BP59,0)),U,6)
+14 WRITE !,"You've chosen to VERIFY Eligibility of the following prescription for "_$EXTRACT($$PATNAME^BPSSCRU2(BPDFN),1,13)
+15 WRITE !,@VALMAR@(+$PIECE(BPRXI,U,5),0)
+16 SET BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
+17 IF BPQ'=1
SET BPQ="^"
GOTO XRES
+18 ;
+19 ;Check to make sure claim can be Submitted for Eligibility
+20 SET BPRXIEN=$PIECE(BP59,".")
+21 SET BPRXR=+$EXTRACT($PIECE(BP59,".",2),1,4)
+22 SET BPSTATUS=$PIECE($$CLAIMST^BPSSCRU3(BP59),U)
+23 IF BPSTATUS'["E REJECTED"
WRITE !!,"The claim: ",!,@VALMAR@(+$PIECE(BPRXI,U,5),0),!,"is NOT Rejected and cannot be Submitted for Eligibility Verification",!
GOTO XRES
+24 ;
+25 ;Prompt for EDIT Information
+26 SET BPPROMPT=$$PROMPTS(BP02,.BPDOSDT,.BPRELCD,.BPPSNCD)
IF BPPROMPT=-1
GOTO XRES
+27 ;
+28 ;Send eligibility verification
+29 ;IEN to the GROUP INSURANCE PLAN (#355.3) file
SET BPSELG("PLAN")=$PIECE($GET(^BPST(BP59,10,1,0)),U,1)
+30 ;Date of Service entered by the user
SET BPSELG("DOS")=BPDOSDT
+31 ;Prescription, if available
SET BPSELG("IEN")=+$PIECE($GET(^BPST(BP59,1)),U,11)
+32 ;Fill Number, if available
SET BPSELG("FILL NUMBER")=+$PIECE($GET(^BPST(BP59,1)),U,1)
+33 SET BPSELG("REL CODE")=BPRELCD
+34 SET BPSELG("PERSON CODE")=BPPSNCD
+35 SET BPRSLT=$$EN^BPSNCPD9(BPDFN,.BPSELG)
+36 ;
+37 ;Print Return Value Message
+38 WRITE !!
+39 WRITE $PIECE(BPRSLT,U,2)
+40 ;
XRES ;
+1 DO PAUSE^VALM1
+2 QUIT
+3 ;
+4 ; Input Values -> BP02 - The BPS CLAIMS entry
+5 ;
+6 ; Output Value -> BPQ - -1 - The user chose to quit
+7 ; "" - The user completed the EDITS
+8 ; BPDOSDT - Effective Date of Eligibility Verification transaction
+9 ; BPRELCD - Patient Relationship Code from file #9002313.19
+10 ; BPPSNCD - Person Code assigned by payer. 1 - 3 characters free text
+11 ;
PROMPTS(BP02,BPDOSDT,BPRELCD,BPPSNCD) ;
+1 IF '$GET(BP02)
SET BPQ=-1
GOTO XPROMPTS
+2 NEW %,BP300,BPFDA,BPFLD,BPMED,BPMSG,BPQ,DIC,DIR,DIROUT,DTOUT,DUOUT,X,Y,DIRUT
+3 SET BPQ=""
+4 ;
+5 ;Pull Information from Claim
+6 SET BP300=$GET(^BPSC(BP02,300))
+7 SET BPRELCD=$TRANSLATE($EXTRACT($PIECE(BP300,U,6),3,99)," ")
+8 SET BPPSNCD=$TRANSLATE($EXTRACT($PIECE(BP300,U,3),3,99)," ")
+9 SET BPDOSDT=$$DOSDATE^BPSSCRRS(BPRXIEN,BPRXR)
+10 ;
+11 ;Effective Date
+12 SET DIR(0)="DO"
SET DIR("A")="Effective Date"
+13 KILL DIR("?")
SET DIR("?")="Enter the effective date for the Eligibility Verification transaction"
+14 SET DIR("B")=$$FMTE^XLFDT(BPDOSDT,"5ZD")
+15 DO ^DIR
+16 IF $DATA(DTOUT)!$DATA(DUOUT)
SET BPQ=-1
GOTO XPROMPTS
+17 SET BPDOSDT=Y
+18 ;
+19 ;Relationship Code
+20 NEW X,DIC,Y
+21 SET DIC("B")=BPRELCD
+22 SET DIC(0)="QEAM"
SET DIC=9002313.19
SET DIC("A")="Relationship Code: "
+23 DO ^DIC
+24 ;Check for "^" or timeout
+25 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
KILL X,DIC,Y
GOTO XPROMPTS
+26 SET BPRELCD=$PIECE(Y,U,2)
+27 KILL X,DIC,Y
+28 ;
+29 ;Person Code
+30 KILL DIR("?")
SET DIR(0)="FO^1:3"
SET DIR("A")="Person Code"
SET DIR("?")="Enter the Specific Person Code Assigned to the Patient by the Payer"
+31 SET DIR("B")=BPPSNCD
+32 DO ^DIR
+33 IF $DATA(DTOUT)!$DATA(DUOUT)
SET BPQ=-1
GOTO XPROMPTS
+34 SET BPPSNCD=Y
+35 ;
+36 ;Ask to proceed
+37 WRITE !
SET BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
+38 IF BPQ'=1
SET BPQ=-1
GOTO XPROMPTS
+39 ;
XPROMPTS ;
+1 QUIT BPQ
+2 ;
+3 ;Prompt User for Claim to Resubmit (w/EDITS)
+4 ;
+5 ; Input values -> BPROMPT - prompt string
+6 ; BPERRMES - the message to display when the user tries
+7 ; to make multi line selection (optional)
+8 ; Piece
+9 ;output values -> 1 - 1 = okay, <0 = errors, 0 = quit
+10 ; 2 - patient ien #2
+11 ; 3 - insurance ien #36
+12 ; 4 - ptr to #9002313.59
+13 ; 5 - 1st line for index(es) in LM "VALM" array
+14 ; 6 - patient's index
+15 ; 7 - claim's index
+16 ;
ASKLINE(BPROMPT,BPERRMES) ;
+1 NEW BPRET,BPCNT
+2 SET BPRET=""
SET BPCNT=0
+3 FOR
SET BPRET=$$SELLINE^BPSSCRU4(BPROMPT,"C",VALMAR,"")
if BPRET'<0
QUIT
Begin DoDot:1
+4 IF BPCNT<1
SET BPCNT=BPCNT+1
WRITE !
+5 IF '$TEST
SET BPCNT=0
DO RE^VALM4
+6 ; (invalid Patient summary line)"
IF BPRET=-1
WRITE "Invalid line number"
+7 IF BPRET=-8
WRITE $SELECT($GET(BPERRMES)]"":BPERRMES,1:" Invalid line number")
+8 ; (invalid RX line)"
IF BPRET=-4
WRITE "Invalid line number"
+9 IF BPRET=-2
WRITE "Please select Patient's summary line."
+10 IF BPRET=-3
WRITE "Please specify RX line."
+11 ; Corrupted array (",BPRET,")"
IF ",-1,-8,-4,-2,-3,"'[(","_BPRET_",")
WRITE "Incorrect format."
End DoDot:1
+12 QUIT BPRET
