BPSRPT3 ;BHAM ISC/BEE - ECME REPORTS ;14-FEB-05
;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,11,14,19,20,23,24**;JUN 2004;Build 43
;;Per VA Directive 6402, this routine should not be modified.
;
;Reference to IB NCPCP NON-BILLABLE STATUS REASONS (#366.17) supported by ICR 6136
;
Q
;
; Select the ECME Pharmacy or Pharmacies
;
; Input Variable -> none
; Return Value -> "" = Valid Entry or Entries Selected
; ^ = Exit
;
; Output Variable -> BPPHARM = 1 One or More Pharmacies Selected
; = 0 User Entered 'ALL'
;
; If BPPHARM = 1 then the BPPHARM array will be defined where:
; BPPHARM(ptr) = ptr ^ BPS PHARMACY NAME and
; ptr = Internal Pointer to BPS PHARMACIES file (#9002313.56)
;
SELPHARM() N DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y
;
;Reset BPPHARM array
K BPPHARM
;
;First see if they want to enter individual divisions or ALL
S DIR(0)="S^D:DIVISION;A:ALL"
S DIR("A")="Select Certain Pharmacy (D)ivisions or (A)LL"
S DIR("L",1)="Select one of the following:"
S DIR("L",2)=""
S DIR("L",3)=" D DIVISION"
S DIR("L",4)=" A ALL"
D ^DIR K DIR
;
;Check for "^" or timeout, otherwise define BPPHARM
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
E S BPPHARM=$S(Y="A":0,1:1)
;
SELPHRM1 ;
;If division selected, ask prompt
I $G(BPPHARM)=1 F D Q:Y="^"!(Y="")
.;
.;Prompt for entry
.K X S DIC(0)="QEAM",DIC=9002313.56,DIC("A")="Select ECME Pharmacy Division(s): "
.W ! D ^DIC
.;
.;Check for "^" or timeout
.I ($G(DUOUT)=1)!($G(DTOUT)=1) K BPPHARM S Y="^" Q
.;
.;Check for blank entry, quit if no previous selections
.I $G(X)="" S Y=$S($D(BPPHARM)>9:"",1:"^") Q
.;
.;Handle Deletes
.I $D(BPPHARM(+Y)) D Q:Y="^" I 1
..N P
..S P=Y ;Save Original Value
..S DIR(0)="S^Y:YES;N:NO",DIR("A")="Delete "_$P(P,U,2)_" from your list?"
..S DIR("B")="NO" D ^DIR
..I ($G(DUOUT)=1)!($G(DTOUT)=1) K BPPHARM S Y="^" Q
..I Y="Y" K BPPHARM(+P),BPPHARM("B",$P(P,U,2),+P)
..S Y=P ;Restore Original Value
..K P
.E D
..;Define new entries in BPPHARM array
..S BPPHARM(+Y)=Y
..S BPPHARM("B",$P(Y,U,2),+Y)=""
.;
.;Display a list of selected divisions
.I $D(BPPHARM)>9 D
..N X
..W !,?2,"Selected:"
..S X="" F S X=$O(BPPHARM("B",X)) Q:X="" W !,?10,X
..K X
.Q
;
K BPPHARM("B")
Q Y
;
; Select to Include Eligibility of (V)ETERAN, (T)RICARE, (C)HAMPVA or (A)ll
;
; Input Variable -> DFLT = 0 = All
; 1 = VETERAN
; 2 = TRICARE
; 3 = CHAMPVA
;
; Return Value -> V, T, C or 0 for All
;
SELELIG(DFLT) N DIC,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
S DFLT=$S($G(DFLT)=1:"V",$G(DFLT)=2:"T",$G(DFLT)=3:"C",1:"A")
S DIR(0)="S^V:VETERAN;T:TRICARE;C:CHAMPVA;A:ALL"
S DIR("A")="Include Certain Eligibility Type or (A)ll",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S Y=$S(Y="A":0,1:Y)
Q Y
;
; Display (S)ummary or (D)etail Format
;
; Input Variable -> DFLT = 1 Summary
; 2 Detail
;
; Return Value -> 1 = Summary
; 0 = Detail
; ^ = Exit
;
SELSMDET(DFLT) N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DFLT=$S($G(DFLT)=1:"Summary",$G(DFLT)=0:"Detail",1:"Detail")
S DIR(0)="S^S:Summary;D:Detail",DIR("A")="Display (S)ummary or (D)etail Format",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S Y=$S(Y="S":1,Y="D":0,1:Y)
Q Y
;
; Display (C)MOP or (M)ail or (W)indow or (A)ll
;
; Input Variable -> DFLT = C CMOP
; W Window
; M Mail
; A All
;
; Return Value -> C = CMOP
; W = Window
; M = Mail
; A = All
; ^ = Exit
;
SELMWC(DFLT) N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DFLT=$S($G(DFLT)="C":"CMOP",$G(DFLT)="W":"Window",$G(DFLT)="M":"Mail",1:"ALL")
S DIR(0)="S^C:CMOP;M:Mail;W:Window;A:ALL"
S DIR("A")="Display (C)MOP or (M)ail or (W)indow or (A)LL",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
Q Y
;
;
SELMWC1(DFLT) ;
; Upon completion of prompt, values will be placed into a string delimited
; by commas. e.g. C,M
;
; If user includes (A)ll as a code, "A" will be stored in BPARR
; array. e.g. Entry of C,M,A will save as BPARR("MWC")="A"
;
; User input values are temporary stored in array BPSMWC to eliminate duplicate
; entries. e.g. Entry of C,M,C will save as BPARR("MWC")="C,M"
;
BPSMWC ;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
N BPARR,BPSMWC,BPSERR,BPSMWCSTR,BPSSEL,BPSX
;
S BPSMWCSTR=",C,M,W,A,"
S DIR(0)="FO^0:7"
S DIR("A",1)=""
S DIR("A",2)=" Select one or more of the following:"
S DIR("A",3)=""
S DIR("A",4)=" C CMOP"
S DIR("A",5)=" M Mail"
S DIR("A",6)=" W Window"
S DIR("A",7)=" A ALL"
S DIR("A",8)=""
S DIR("A")="Display (C)MOP or (M)ail or (W)indow or (A)ll"
S DIR("B")="A" S:$G(BPARR("MWC"))'="" DIR("B")=BPARR("MWC")
S DIR("?",1)="Enter a single response or multiple responses separated by commas."
S DIR("?",2)=" Example:"
S DIR("?",3)=" C"
S DIR("?")=" C,M"
D ^DIR K DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1)!($D(DIRUT)) Q "^"
;
;Convert any lower case to upper case
S X=$TR(X,BPSLC,BPSUC)
;
;If 'A' was one of the selections,reset X to include all available selections.
I X[",",X["A" S X="C,M,W"
;
; Loop through user input (returned in variable X).
; Display warning message if any user input selection is not included
; in the string of acceptable codes (BPSMWCSTR) and re-prompt question.
; Assign valid selections to BPSMWC array. This array will prevent
; duplicate entries from being saved to the user's profile.
;
K BPSMWC
S BPSERR=""
F BPSX=1:1:$L(X,",") D
. S BPSSEL=$P(X,",",BPSX)
. I BPSMWCSTR'[(","_BPSSEL_",") W !," ",BPSSEL," is not a valid entry." S BPSERR=1 Q
. S BPSMWC(BPSSEL)=""
;
I $G(BPSERR)=1 G BPSMWC
;
; If user included (A)ll as a selection, set profile setting to "A".
;
I $D(BPSMWC("A")) S BPARR("MWC")="A"
E D ; User did not enter "A".
. ;
. ; At this point user selections are valid, do not include "A".
. ; Loop through and set selections into a comma delimited
. ; string before assigning to BPARR array.
. ;
. S BPSSEL=""
. F S BPSSEL=$O(BPSMWC(BPSSEL)) Q:BPSSEL="" D
. . ; Display the user selections
. . W !,?10,$S(BPSSEL="C":"CMOP",BPSSEL="M":"MAIL",BPSSEL="W":"WINDOW",1:"")
. . S BPSMWC=$G(BPSMWC)_BPSSEL_","
. S BPSMWC=$E(BPSMWC,1,($L(BPSMWC)-1))
. S BPARR("MWC")=BPSMWC
;
Q BPARR("MWC")
;
; Display (R)ealTime Fills or (B)ackbills or (P)RO option or Re(S)ubmission or (A)LL
;
; Input Variable -> DFLT = 5 Resubmission
; 4 PRO Option
; 3 Backbill
; 2 Real Time Fills
; 1 ALL
;
; Return Value -> 5 = Resubmision
; 4 = PRO Option
; 3 = Backbill (manually)
; 2 = Real Time Fills (automatically during FINISH)
; 1 = ALL
; ^ = Exit
;
SELRTBCK(DFLT) N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
S DFLT=$S($G(DFLT)=2:"Real Time",$G(DFLT)=3:"Backbill",$G(DFLT)=4:"PRO Option",$G(DFLT)=5:"Resubmission",1:"A")
S DIR(0)="S^R:Real Time Fills;B:Backbill;P:PRO Option;S:ReSubmission;A:ALL"
S DIR("A")="Display (R)ealTime, (B)ackbills, (P)RO Option, Re(S)ubmission or (A)LL",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S Y=$S(Y="A":1,Y="R":2,Y="B":3,Y="P":4,Y="S":5,1:Y)
Q Y
;
SELRBPS() ;
;
; BPSRBSTR = string of valid codes
;
; Upon completion of prompt, values will be placed into a string delimited
; by commas. e.g. P,R
;
; If user selected (A)ll then 1 will be stored in BPARR
;
; User input values are temporary stored in array BPSRBPS to eliminate duplicate
; entries.
;
BPRBPS ; Realtime / Backbills / Pro Option / Resubmission / All
N BPARR,BPSRBPS,BPSERR,BPSRBSTR,BPSSEL,BPSX
N DIR,DIRUT,DTOUT,DUOUT,X,Y
;
S BPSRBSTR=",R,B,P,S,A,"
S DIR(0)="FO^0:9"
S DIR("A",1)=""
S DIR("A",2)=" Select one or more of the following:"
S DIR("A",3)=""
S DIR("A",4)=" R Real Time Fills"
S DIR("A",5)=" B Backbill"
S DIR("A",6)=" P PRO Option"
S DIR("A",7)=" S ReSubmission"
S DIR("A",8)=" A ALL"
S DIR("A",9)=""
S DIR("A")="Display (R)ealTime, (B)ackbills, (P)RO Option, Re(S)ubmission or (A)ll"
S DIR("B")="A" S:$G(BPARR("RBPS"))'="" DIR("B")=BPARR("RBPS")
S DIR("?",1)="Enter a single response or multiple responses separated by commas."
S DIR("?",2)=" Example:"
S DIR("?",3)=" B"
S DIR("?")=" B,P"
D ^DIR K DIR
;
I ($G(DUOUT)=1)!($G(DTOUT)=1)!($D(DIRUT)) Q "^"
;
;Convert any lower case to upper case
S X=$TR(X,BPSLC,BPSUC)
;
;If 'A' was one of the selections,reset X to include all available selections.
I X[",",X["A" S X="R,B,P,S"
;
; Loop through user input (returned in variable X).
; Display warning message if any user input selection is not included
; in the string of acceptable codes (BPSRBSTR) and re-prompt question.
; Assign valid selections to BPRTBCK array. This array will prevent
; duplicate entries from being saved to the user's profile.
;
K BPSRBPS
S (BPSSEL,BPSERR)=""
F BPSX=1:1:$L(X,",") D
. S BPSSEL=$P(X,",",BPSX)
. I BPSRBSTR'[(","_BPSSEL_",") W !," ",BPSSEL," is not a valid entry." S BPSERR=1 Q
. S BPSRBPS(BPSSEL)=""
;
I $G(BPSERR)=1 G BPRBPS
;
; If user selected (A)ll, set profile setting to ALL.
I $D(BPSRBPS("A")) S BPARR("RBPS")=1
E D ; User did not enter "A".
. ;
. ; At this point user selections are valid and do not include "A".
. ; Loop through valid user selections. Set selections into a
. ; comma delimited string before assigning to BPARR array.
. ;
. S (BPSSEL,BPSSELN)=""
. F S BPSSEL=$O(BPSRBPS(BPSSEL)) Q:BPSSEL="" D
. . ; Display the user selections
. . W !,?10,$S(BPSSEL="R":"REALTIME",BPSSEL="B":"BACKBILLS",BPSSEL="P":"PRO OPTION",BPSSEL="S":"RESUBMISSION",1:"")
. . S BPSRBPS=$G(BPSRBPS)_BPSSEL_","
. S BPSRBPS=$E(BPSRBPS,1,($L(BPSRBPS)-1))
;
; If ALL wasn't selected convert BPSRBPS to numerical a value, like existing functionality in SELRTBCK^BPSRPT3.
I '$D(BPSRBPS("A")) D
. N RTBCKX,NRTBCK,I
. S NRTBCK=""
. I $L(BPSRBPS)=1 D
. . S NRTBCK=$S(BPSRBPS="R":2,BPSRBPS="B":3,BPSRBPS="P":4,BPSRBPS="S":5,1:"")
. . S BPARR("RBPS")=NRTBCK
. E D
. . F I=1:1:$L(BPSRBPS,",") S RTBCKX=$P(BPSRBPS,",",I),NRTBCK=NRTBCK_$S(RTBCKX="R":2,RTBCKX="B":3,RTBCKX="P":4,RTBCKX="S":5,1:"")_","
. . S BPARR("RBPS")=$E(NRTBCK,1,$L(NRTBCK)-1)
;
Q BPARR("RBPS")
;
; Display Specific (D)rug or Drug (C)lass
;
; Input Variable -> DFLT = 3 Drug Class
; 2 Drug
; 1 ALL
;
; Return Value -> 3 = Drug Class
; 2 = Drug
; 1 = ALL
; ^ = Exit
;
SELDRGAL(DFLT) N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DFLT=$S($G(DFLT)=2:"Drug",$G(DFLT)=3:"Drug Class",1:"ALL")
S DIR(0)="S^D:Drug;C:Drug Class;A:ALL"
S DIR("A")="Display Specific (D)rug or Drug (C)lass or (A)LL",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S Y=$S(Y="A":1,Y="D":2,Y="C":3,1:Y)
Q Y
;
; Select Drug
;
; Input Variable -> none
;
; Return Value -> ptr = pointer to DRUG file (#50)
; ^ = Exit
;
SELDRG() N DIC,DIRUT,DUOUT,X,Y
;
;Prompt for entry
W ! D SELDRG^BPSRPT6
;
;Check for "^", timeout, or blank entry
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
;
;Check for Valid Entry
I +Y>0 S Y=+Y
;
Q Y
;
; Select Drug Class
;
; Input Variable -> none
;
; Return Value -> ptr = pointer to VA DRUG CLASS file (#50.605)
; ^ = Exit
;
SELDRGCL() N DIC,DIRUT,DUOUT,Y
;
;Prompt for entry
;Using DIC^PSNDI per ICR 4554 - BPS*1*14 ticket 313337
S DIC="50.605",DIC(0)="QEAMZ" D DIC^PSNDI(DIC,"BPS",.DIC,,,)
;
;call returns DRUG CLASS CODE, need to extract DRUG CLASSIFICATION
I +$G(Y)>0 S Y=$P($G(Y(0)),"^",2) I $G(Y)="" S Y=-1
;
;If nothing was returned set Y="-1" so report knows
I $G(Y)=-1 S Y="^"
;
Q Y
;
; Enter Date Range
;
; Input Variable -> TYPE = 7 CLOSE REPORT
; 1-6 OTHER REPORTS
;
; Return Value -> P1^P2
;
; where P1 = From Date
; = ^ Exit
; P2 = To Date
; = blank for Exit
;
SELDATE(TYPE) N BPSIBDT,DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y
S TYPE=$S($G(TYPE)=7:"CLOSE",1:"TRANSACTION")
SELDATE1 S VAL="",DIR(0)="DA^:DT:EX",DIR("A")="START WITH "_TYPE_" DATE: ",DIR("B")="T-1"
W ! D ^DIR
;
;Check for "^", timeout, or blank entry
I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^"
;
I VAL="" D
.S $P(VAL,U)=Y
.S DIR(0)="DA^"_VAL_":DT:EX",DIR("A")=" GO TO "_TYPE_" DATE: ",DIR("B")="T"
.D ^DIR
.;
.;Check for "^", timeout, or blank entry
.I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^" Q
.;
.;Define Entry
.S $P(VAL,U,2)=Y
;
Q VAL
;
; Select to Include Open or Closed or All claims
;
; Input Variable -> DFLT = 0 = All
; 1 = Closed
; 2 = Open
;
; Return Value -> 0 = All, 1 = Closed, 2 = Open
SELOPCL(DFLT) N DIC,DIR,DIRUT,DUOUT,X,Y
;
S DFLT=$S($G(DFLT)=1:"C",$G(DFLT)=2:"O",1:"A")
S DIR(0)="S^O:OPEN;C:CLOSED;A:ALL"
S DIR("A")="Include (O)pen, (C)losed, or (A)ll Claims",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
;
S Y=$S(Y="C":1,Y="O":2,1:0)
Q Y
;
SELELIG1() ;
; Select multiple Eligibilities
;
; Input Variable -> none
; Return Value -> 0: All, 1: Selected Eligibilities; '^' = Exit
;
; Output Variable -> BPELIG1 = 1 - One or More Eligibilities Selected
; = 0 - User Entered 'ALL'
; = "^" - User quit
;
; If BPELIG1 = 1 then the BPELIG1 array will be defined where:
; BPELIG1("C")="CHAMPVA"
; BPELIG1("T")="TRICARE"
; BPELIG1("V")="VETERAN"
;
;
BPSELIG1 ;
;Reset BPELIG1 array
K BPELIG1
N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,P
N BPSVTC,BPSERR,BPSVTCSTR,BPSSEL,BPSX
;
S BPSVTCSTR=",V,T,C,A,"
S DIR(0)="FO^0:7"
S DIR("A",1)=""
S DIR("A",2)="Select one or more of the following:"
S DIR("A",3)=""
S DIR("A",4)=" V VETERAN"
S DIR("A",5)=" T TRICARE"
S DIR("A",6)=" C CHAMPVA"
S DIR("A",7)=" A ALL"
S DIR("A",8)=""
S DIR("A")="Display (V)ETERAN or (T)RICARE or (C)HAMPVA or (A)LL"
S DIR("B")="A" S:$G(BPARR("ELIG"))'="" DIR("B")=BPARR("ELIG")
S DIR("?",1)="Enter a single response or multiple responses separated by commas."
S DIR("?",2)=" Example:"
S DIR("?",3)=" T"
S DIR("?")=" T,C"
D ^DIR K DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1)!($D(DIRUT)) Q "^"
;
;Convert any lower case to upper case
S X=$TR(X,BPSLC,BPSUC)
;
;If 'A' was one of the selections, reset X to include all available selections.
I X[",",X["A" S X="V,T,C"
;
; Loop through user input (returned in variable X).
; Display warning message if any user input selection is not included
; in the string of acceptable codes (BPSVTCSTR) and re-prompt question.
; Assign valid selections to BPSVTC array. This array will prevent
; duplicate entries from being saved to the user's profile.
;
K BPSVTC
S BPSERR=""
F BPSX=1:1:$L(X,",") D
. S BPSSEL=$P(X,",",BPSX)
. I BPSVTCSTR'[(","_BPSSEL_",") W !," ",BPSSEL," is not a valid entry." S BPSERR=1 Q
. ; if All was selected don't include in array
. I BPSSEL'="A" S BPELIG1(BPSSEL)=$S(BPSSEL="V":"VETERAN",BPSSEL="T":"TRICARE",BPSSEL="C":"CHAMPVA",1:"")
;
I $G(BPSERR)=1 G BPSELIG1
;
; ALL was selected
I X="A" S BPELIG1=0
E D ;
. ;User selected one or more eligibilities
. S BPELIG1=1
. ;
. ; Display the user selections
. ;
. S BPSSEL=""
. F S BPSSEL=$O(BPELIG1(BPSSEL)) Q:BPSSEL="" W !,?10,BPELIG1(BPSSEL)
;
Q BPELIG1
;
SELALRC() ;
; Display Most (R)ecent or (A)ll
;
; Return Value -> A: All
; R: Most Recent
; ^: Exit
;
N DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT
;
S DIR(0)="S^R:Most Recent;A:ALL"
S DIR("A")="Select Most (R)ecent or (A)ll"
S DIR("B")="MOST RECENT"
S DIR("L",1)="Select one of the following:"
S DIR("L",2)=""
S DIR("L",3)=" R Most Recent Transaction Only"
S DIR("L",4)=" A ALL Transactions (will list the Rx/Fill each time resubmitted)"
D ^DIR K DIR
;
;Check for "^" or timeout,
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
Q Y
;
SELNBSTS() ;
; Select the Non-Billable Status Reason
;
; Input Variable -> None
; Return Value -> 0: All, 1: Selected Non-Billable Status; '^' = Exit
;
; Output Variable -> BPNBSTS = 1 - One or More Non-Billable Statuses Selected
; = 0 - User Entered 'ALL'
; = "" - User quit
;
; If BPNBSTS = 1 then the BPNBSTS array will be defined where:
; BPNBSTS(Non-Billable Status IEN)=Non-Billable Status Reason
;
;Reset BPNBSTS array
K BPNBSTS
N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,P,DIC
;
;First see if they want to enter individual eligibilities or ALL
S DIR(0)="S^S:NON-BILLABLE STATUS;A:ALL"
S DIR("A")="Select Certain Non-Billable (S)tatus or (A)ll"
S DIR("B")="ALL"
S DIR("L",1)="Select one of the following:"
S DIR("L",2)=""
S DIR("L",3)=" S NON-BILLABLE STATUS"
S DIR("L",4)=" A ALL"
D ^DIR K DIR
;
;Check for "^" or timeout, otherwise define BPNBSTS
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S BPNBSTS=$S(Y="A":0,Y="^":"^",1:1)
I BPNBSTS'=1 Q BPNBSTS
;
;Allow user to select multiple non-billable statuses
F D Q:Y="^"!(Y="")
.;Prompt for entry - ICR 6136
.K X
.S DIC(0)="QEAM",DIC=366.17,DIC("A")="Select Non-Billable Reason: "
.W ! D ^DIC
.I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" Q
.;
.;Check for blank entry, quit if no previous selections
.I $G(Y)=-1 S Y=$S($D(BPNBSTS)>9:"",1:"^") Q
.;
.; Add entry to array or handle duplicate entries
.I '$D(BPNBSTS($P(Y,U,1))) S BPNBSTS($P(Y,U,1))=$P(Y,U,2),BPNBSTS("B",$P(Y,U,2),$P(Y,U,1))=""
.E D I Y="^" Q
..;Already in the array, so ask whether to delete
..N P
..S P=Y ;Save Original Value
..S DIR(0)="S^Y:YES;N:NO",DIR("A")="Delete "_$P(P,U,2)_" from your list?"
..S DIR("B")="NO"
..D ^DIR
..I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" Q
..I Y="Y" K BPNBSTS($P(P,U,1)),BPNBSTS("B",$P(P,U,2),$P(P,U,1))
..S Y=P ;Restore Original Value
..K P
.;
.;Display a list of selected values
.I $D(BPNBSTS)>9 D
..N X
..W !,?2,"Selected:"
..S X="" F S X=$O(BPNBSTS("B",X)) Q:X="" W !,?10,X
..K X
.Q
;
; Reset BPNBSTS array if user exited
I Y="^" K BPNBSTS S BPNBSTS="^" Q "^"
;
; Deleted 'x-ref' as we don't need to return that
K BPNBSTS("B")
;
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSRPT3 19700 printed Sep 23, 2025@19:28:55 Page 2
BPSRPT3 ;BHAM ISC/BEE - ECME REPORTS ;14-FEB-05
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,11,14,19,20,23,24**;JUN 2004;Build 43
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Reference to IB NCPCP NON-BILLABLE STATUS REASONS (#366.17) supported by ICR 6136
+5 ;
+6 QUIT
+7 ;
+8 ; Select the ECME Pharmacy or Pharmacies
+9 ;
+10 ; Input Variable -> none
+11 ; Return Value -> "" = Valid Entry or Entries Selected
+12 ; ^ = Exit
+13 ;
+14 ; Output Variable -> BPPHARM = 1 One or More Pharmacies Selected
+15 ; = 0 User Entered 'ALL'
+16 ;
+17 ; If BPPHARM = 1 then the BPPHARM array will be defined where:
+18 ; BPPHARM(ptr) = ptr ^ BPS PHARMACY NAME and
+19 ; ptr = Internal Pointer to BPS PHARMACIES file (#9002313.56)
+20 ;
SELPHARM() NEW DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y
+1 ;
+2 ;Reset BPPHARM array
+3 KILL BPPHARM
+4 ;
+5 ;First see if they want to enter individual divisions or ALL
+6 SET DIR(0)="S^D:DIVISION;A:ALL"
+7 SET DIR("A")="Select Certain Pharmacy (D)ivisions or (A)LL"
+8 SET DIR("L",1)="Select one of the following:"
+9 SET DIR("L",2)=""
+10 SET DIR("L",3)=" D DIVISION"
+11 SET DIR("L",4)=" A ALL"
+12 DO ^DIR
KILL DIR
+13 ;
+14 ;Check for "^" or timeout, otherwise define BPPHARM
+15 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+16 IF '$TEST
SET BPPHARM=$SELECT(Y="A":0,1:1)
+17 ;
SELPHRM1 ;
+1 ;If division selected, ask prompt
+2 IF $GET(BPPHARM)=1
FOR
Begin DoDot:1
+3 ;
+4 ;Prompt for entry
+5 KILL X
SET DIC(0)="QEAM"
SET DIC=9002313.56
SET DIC("A")="Select ECME Pharmacy Division(s): "
+6 WRITE !
DO ^DIC
+7 ;
+8 ;Check for "^" or timeout
+9 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
KILL BPPHARM
SET Y="^"
QUIT
+10 ;
+11 ;Check for blank entry, quit if no previous selections
+12 IF $GET(X)=""
SET Y=$SELECT($DATA(BPPHARM)>9:"",1:"^")
QUIT
+13 ;
+14 ;Handle Deletes
+15 IF $DATA(BPPHARM(+Y))
Begin DoDot:2
+16 NEW P
+17 ;Save Original Value
SET P=Y
+18 SET DIR(0)="S^Y:YES;N:NO"
SET DIR("A")="Delete "_$PIECE(P,U,2)_" from your list?"
+19 SET DIR("B")="NO"
DO ^DIR
+20 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
KILL BPPHARM
SET Y="^"
QUIT
+21 IF Y="Y"
KILL BPPHARM(+P),BPPHARM("B",$PIECE(P,U,2),+P)
+22 ;Restore Original Value
SET Y=P
+23 KILL P
End DoDot:2
if Y="^"
QUIT
IF 1
+24 IF '$TEST
Begin DoDot:2
+25 ;Define new entries in BPPHARM array
+26 SET BPPHARM(+Y)=Y
+27 SET BPPHARM("B",$PIECE(Y,U,2),+Y)=""
End DoDot:2
+28 ;
+29 ;Display a list of selected divisions
+30 IF $DATA(BPPHARM)>9
Begin DoDot:2
+31 NEW X
+32 WRITE !,?2,"Selected:"
+33 SET X=""
FOR
SET X=$ORDER(BPPHARM("B",X))
if X=""
QUIT
WRITE !,?10,X
+34 KILL X
End DoDot:2
+35 QUIT
End DoDot:1
if Y="^"!(Y="")
QUIT
+36 ;
+37 KILL BPPHARM("B")
+38 QUIT Y
+39 ;
+40 ; Select to Include Eligibility of (V)ETERAN, (T)RICARE, (C)HAMPVA or (A)ll
+41 ;
+42 ; Input Variable -> DFLT = 0 = All
+43 ; 1 = VETERAN
+44 ; 2 = TRICARE
+45 ; 3 = CHAMPVA
+46 ;
+47 ; Return Value -> V, T, C or 0 for All
+48 ;
SELELIG(DFLT) NEW DIC,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+1 SET DFLT=$SELECT($GET(DFLT)=1:"V",$GET(DFLT)=2:"T",$GET(DFLT)=3:"C",1:"A")
+2 SET DIR(0)="S^V:VETERAN;T:TRICARE;C:CHAMPVA;A:ALL"
+3 SET DIR("A")="Include Certain Eligibility Type or (A)ll"
SET DIR("B")=DFLT
+4 DO ^DIR
+5 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+6 SET Y=$SELECT(Y="A":0,1:Y)
+7 QUIT Y
+8 ;
+9 ; Display (S)ummary or (D)etail Format
+10 ;
+11 ; Input Variable -> DFLT = 1 Summary
+12 ; 2 Detail
+13 ;
+14 ; Return Value -> 1 = Summary
+15 ; 0 = Detail
+16 ; ^ = Exit
+17 ;
SELSMDET(DFLT) NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+1 SET DFLT=$SELECT($GET(DFLT)=1:"Summary",$GET(DFLT)=0:"Detail",1:"Detail")
+2 SET DIR(0)="S^S:Summary;D:Detail"
SET DIR("A")="Display (S)ummary or (D)etail Format"
SET DIR("B")=DFLT
+3 DO ^DIR
+4 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+5 SET Y=$SELECT(Y="S":1,Y="D":0,1:Y)
+6 QUIT Y
+7 ;
+8 ; Display (C)MOP or (M)ail or (W)indow or (A)ll
+9 ;
+10 ; Input Variable -> DFLT = C CMOP
+11 ; W Window
+12 ; M Mail
+13 ; A All
+14 ;
+15 ; Return Value -> C = CMOP
+16 ; W = Window
+17 ; M = Mail
+18 ; A = All
+19 ; ^ = Exit
+20 ;
SELMWC(DFLT) NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+1 SET DFLT=$SELECT($GET(DFLT)="C":"CMOP",$GET(DFLT)="W":"Window",$GET(DFLT)="M":"Mail",1:"ALL")
+2 SET DIR(0)="S^C:CMOP;M:Mail;W:Window;A:ALL"
+3 SET DIR("A")="Display (C)MOP or (M)ail or (W)indow or (A)LL"
SET DIR("B")=DFLT
+4 DO ^DIR
+5 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+6 QUIT Y
+7 ;
+8 ;
SELMWC1(DFLT) ;
+1 ; Upon completion of prompt, values will be placed into a string delimited
+2 ; by commas. e.g. C,M
+3 ;
+4 ; If user includes (A)ll as a code, "A" will be stored in BPARR
+5 ; array. e.g. Entry of C,M,A will save as BPARR("MWC")="A"
+6 ;
+7 ; User input values are temporary stored in array BPSMWC to eliminate duplicate
+8 ; entries. e.g. Entry of C,M,C will save as BPARR("MWC")="C,M"
+9 ;
BPSMWC ;
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 NEW BPARR,BPSMWC,BPSERR,BPSMWCSTR,BPSSEL,BPSX
+3 ;
+4 SET BPSMWCSTR=",C,M,W,A,"
+5 SET DIR(0)="FO^0:7"
+6 SET DIR("A",1)=""
+7 SET DIR("A",2)=" Select one or more of the following:"
+8 SET DIR("A",3)=""
+9 SET DIR("A",4)=" C CMOP"
+10 SET DIR("A",5)=" M Mail"
+11 SET DIR("A",6)=" W Window"
+12 SET DIR("A",7)=" A ALL"
+13 SET DIR("A",8)=""
+14 SET DIR("A")="Display (C)MOP or (M)ail or (W)indow or (A)ll"
+15 SET DIR("B")="A"
if $GET(BPARR("MWC"))'=""
SET DIR("B")=BPARR("MWC")
+16 SET DIR("?",1)="Enter a single response or multiple responses separated by commas."
+17 SET DIR("?",2)=" Example:"
+18 SET DIR("?",3)=" C"
+19 SET DIR("?")=" C,M"
+20 DO ^DIR
KILL DIR
+21 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)!($DATA(DIRUT))
QUIT "^"
+22 ;
+23 ;Convert any lower case to upper case
+24 SET X=$TRANSLATE(X,BPSLC,BPSUC)
+25 ;
+26 ;If 'A' was one of the selections,reset X to include all available selections.
+27 IF X[","
IF X["A"
SET X="C,M,W"
+28 ;
+29 ; Loop through user input (returned in variable X).
+30 ; Display warning message if any user input selection is not included
+31 ; in the string of acceptable codes (BPSMWCSTR) and re-prompt question.
+32 ; Assign valid selections to BPSMWC array. This array will prevent
+33 ; duplicate entries from being saved to the user's profile.
+34 ;
+35 KILL BPSMWC
+36 SET BPSERR=""
+37 FOR BPSX=1:1:$LENGTH(X,",")
Begin DoDot:1
+38 SET BPSSEL=$PIECE(X,",",BPSX)
+39 IF BPSMWCSTR'[(","_BPSSEL_",")
WRITE !," ",BPSSEL," is not a valid entry."
SET BPSERR=1
QUIT
+40 SET BPSMWC(BPSSEL)=""
End DoDot:1
+41 ;
+42 IF $GET(BPSERR)=1
GOTO BPSMWC
+43 ;
+44 ; If user included (A)ll as a selection, set profile setting to "A".
+45 ;
+46 IF $DATA(BPSMWC("A"))
SET BPARR("MWC")="A"
+47 ; User did not enter "A".
IF '$TEST
Begin DoDot:1
+48 ;
+49 ; At this point user selections are valid, do not include "A".
+50 ; Loop through and set selections into a comma delimited
+51 ; string before assigning to BPARR array.
+52 ;
+53 SET BPSSEL=""
+54 FOR
SET BPSSEL=$ORDER(BPSMWC(BPSSEL))
if BPSSEL=""
QUIT
Begin DoDot:2
+55 ; Display the user selections
+56 WRITE !,?10,$SELECT(BPSSEL="C":"CMOP",BPSSEL="M":"MAIL",BPSSEL="W":"WINDOW",1:"")
+57 SET BPSMWC=$GET(BPSMWC)_BPSSEL_","
End DoDot:2
+58 SET BPSMWC=$EXTRACT(BPSMWC,1,($LENGTH(BPSMWC)-1))
+59 SET BPARR("MWC")=BPSMWC
End DoDot:1
+60 ;
+61 QUIT BPARR("MWC")
+62 ;
+63 ; Display (R)ealTime Fills or (B)ackbills or (P)RO option or Re(S)ubmission or (A)LL
+64 ;
+65 ; Input Variable -> DFLT = 5 Resubmission
+66 ; 4 PRO Option
+67 ; 3 Backbill
+68 ; 2 Real Time Fills
+69 ; 1 ALL
+70 ;
+71 ; Return Value -> 5 = Resubmision
+72 ; 4 = PRO Option
+73 ; 3 = Backbill (manually)
+74 ; 2 = Real Time Fills (automatically during FINISH)
+75 ; 1 = ALL
+76 ; ^ = Exit
+77 ;
SELRTBCK(DFLT) NEW DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
+1 SET DFLT=$SELECT($GET(DFLT)=2:"Real Time",$GET(DFLT)=3:"Backbill",$GET(DFLT)=4:"PRO Option",$GET(DFLT)=5:"Resubmission",1:"A")
+2 SET DIR(0)="S^R:Real Time Fills;B:Backbill;P:PRO Option;S:ReSubmission;A:ALL"
+3 SET DIR("A")="Display (R)ealTime, (B)ackbills, (P)RO Option, Re(S)ubmission or (A)LL"
SET DIR("B")=DFLT
+4 DO ^DIR
+5 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+6 SET Y=$SELECT(Y="A":1,Y="R":2,Y="B":3,Y="P":4,Y="S":5,1:Y)
+7 QUIT Y
+8 ;
SELRBPS() ;
+1 ;
+2 ; BPSRBSTR = string of valid codes
+3 ;
+4 ; Upon completion of prompt, values will be placed into a string delimited
+5 ; by commas. e.g. P,R
+6 ;
+7 ; If user selected (A)ll then 1 will be stored in BPARR
+8 ;
+9 ; User input values are temporary stored in array BPSRBPS to eliminate duplicate
+10 ; entries.
+11 ;
BPRBPS ; Realtime / Backbills / Pro Option / Resubmission / All
+1 NEW BPARR,BPSRBPS,BPSERR,BPSRBSTR,BPSSEL,BPSX
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 ;
+4 SET BPSRBSTR=",R,B,P,S,A,"
+5 SET DIR(0)="FO^0:9"
+6 SET DIR("A",1)=""
+7 SET DIR("A",2)=" Select one or more of the following:"
+8 SET DIR("A",3)=""
+9 SET DIR("A",4)=" R Real Time Fills"
+10 SET DIR("A",5)=" B Backbill"
+11 SET DIR("A",6)=" P PRO Option"
+12 SET DIR("A",7)=" S ReSubmission"
+13 SET DIR("A",8)=" A ALL"
+14 SET DIR("A",9)=""
+15 SET DIR("A")="Display (R)ealTime, (B)ackbills, (P)RO Option, Re(S)ubmission or (A)ll"
+16 SET DIR("B")="A"
if $GET(BPARR("RBPS"))'=""
SET DIR("B")=BPARR("RBPS")
+17 SET DIR("?",1)="Enter a single response or multiple responses separated by commas."
+18 SET DIR("?",2)=" Example:"
+19 SET DIR("?",3)=" B"
+20 SET DIR("?")=" B,P"
+21 DO ^DIR
KILL DIR
+22 ;
+23 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)!($DATA(DIRUT))
QUIT "^"
+24 ;
+25 ;Convert any lower case to upper case
+26 SET X=$TRANSLATE(X,BPSLC,BPSUC)
+27 ;
+28 ;If 'A' was one of the selections,reset X to include all available selections.
+29 IF X[","
IF X["A"
SET X="R,B,P,S"
+30 ;
+31 ; Loop through user input (returned in variable X).
+32 ; Display warning message if any user input selection is not included
+33 ; in the string of acceptable codes (BPSRBSTR) and re-prompt question.
+34 ; Assign valid selections to BPRTBCK array. This array will prevent
+35 ; duplicate entries from being saved to the user's profile.
+36 ;
+37 KILL BPSRBPS
+38 SET (BPSSEL,BPSERR)=""
+39 FOR BPSX=1:1:$LENGTH(X,",")
Begin DoDot:1
+40 SET BPSSEL=$PIECE(X,",",BPSX)
+41 IF BPSRBSTR'[(","_BPSSEL_",")
WRITE !," ",BPSSEL," is not a valid entry."
SET BPSERR=1
QUIT
+42 SET BPSRBPS(BPSSEL)=""
End DoDot:1
+43 ;
+44 IF $GET(BPSERR)=1
GOTO BPRBPS
+45 ;
+46 ; If user selected (A)ll, set profile setting to ALL.
+47 IF $DATA(BPSRBPS("A"))
SET BPARR("RBPS")=1
+48 ; User did not enter "A".
IF '$TEST
Begin DoDot:1
+49 ;
+50 ; At this point user selections are valid and do not include "A".
+51 ; Loop through valid user selections. Set selections into a
+52 ; comma delimited string before assigning to BPARR array.
+53 ;
+54 SET (BPSSEL,BPSSELN)=""
+55 FOR
SET BPSSEL=$ORDER(BPSRBPS(BPSSEL))
if BPSSEL=""
QUIT
Begin DoDot:2
+56 ; Display the user selections
+57 WRITE !,?10,$SELECT(BPSSEL="R":"REALTIME",BPSSEL="B":"BACKBILLS",BPSSEL="P":"PRO OPTION",BPSSEL="S":"RESUBMISSION",1:"")
+58 SET BPSRBPS=$GET(BPSRBPS)_BPSSEL_","
End DoDot:2
+59 SET BPSRBPS=$EXTRACT(BPSRBPS,1,($LENGTH(BPSRBPS)-1))
End DoDot:1
+60 ;
+61 ; If ALL wasn't selected convert BPSRBPS to numerical a value, like existing functionality in SELRTBCK^BPSRPT3.
+62 IF '$DATA(BPSRBPS("A"))
Begin DoDot:1
+63 NEW RTBCKX,NRTBCK,I
+64 SET NRTBCK=""
+65 IF $LENGTH(BPSRBPS)=1
Begin DoDot:2
+66 SET NRTBCK=$SELECT(BPSRBPS="R":2,BPSRBPS="B":3,BPSRBPS="P":4,BPSRBPS="S":5,1:"")
+67 SET BPARR("RBPS")=NRTBCK
End DoDot:2
+68 IF '$TEST
Begin DoDot:2
+69 FOR I=1:1:$LENGTH(BPSRBPS,",")
SET RTBCKX=$PIECE(BPSRBPS,",",I)
SET NRTBCK=NRTBCK_$SELECT(RTBCKX="R":2,RTBCKX="B":3,RTBCKX="P":4,RTBCKX="S":5,1:"")_","
+70 SET BPARR("RBPS")=$EXTRACT(NRTBCK,1,$LENGTH(NRTBCK)-1)
End DoDot:2
End DoDot:1
+71 ;
+72 QUIT BPARR("RBPS")
+73 ;
+74 ; Display Specific (D)rug or Drug (C)lass
+75 ;
+76 ; Input Variable -> DFLT = 3 Drug Class
+77 ; 2 Drug
+78 ; 1 ALL
+79 ;
+80 ; Return Value -> 3 = Drug Class
+81 ; 2 = Drug
+82 ; 1 = ALL
+83 ; ^ = Exit
+84 ;
SELDRGAL(DFLT) NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+1 SET DFLT=$SELECT($GET(DFLT)=2:"Drug",$GET(DFLT)=3:"Drug Class",1:"ALL")
+2 SET DIR(0)="S^D:Drug;C:Drug Class;A:ALL"
+3 SET DIR("A")="Display Specific (D)rug or Drug (C)lass or (A)LL"
SET DIR("B")=DFLT
+4 DO ^DIR
+5 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+6 SET Y=$SELECT(Y="A":1,Y="D":2,Y="C":3,1:Y)
+7 QUIT Y
+8 ;
+9 ; Select Drug
+10 ;
+11 ; Input Variable -> none
+12 ;
+13 ; Return Value -> ptr = pointer to DRUG file (#50)
+14 ; ^ = Exit
+15 ;
SELDRG() NEW DIC,DIRUT,DUOUT,X,Y
+1 ;
+2 ;Prompt for entry
+3 WRITE !
DO SELDRG^BPSRPT6
+4 ;
+5 ;Check for "^", timeout, or blank entry
+6 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+7 ;
+8 ;Check for Valid Entry
+9 IF +Y>0
SET Y=+Y
+10 ;
+11 QUIT Y
+12 ;
+13 ; Select Drug Class
+14 ;
+15 ; Input Variable -> none
+16 ;
+17 ; Return Value -> ptr = pointer to VA DRUG CLASS file (#50.605)
+18 ; ^ = Exit
+19 ;
SELDRGCL() NEW DIC,DIRUT,DUOUT,Y
+1 ;
+2 ;Prompt for entry
+3 ;Using DIC^PSNDI per ICR 4554 - BPS*1*14 ticket 313337
+4 SET DIC="50.605"
SET DIC(0)="QEAMZ"
DO DIC^PSNDI(DIC,"BPS",.DIC,,,)
+5 ;
+6 ;call returns DRUG CLASS CODE, need to extract DRUG CLASSIFICATION
+7 IF +$GET(Y)>0
SET Y=$PIECE($GET(Y(0)),"^",2)
IF $GET(Y)=""
SET Y=-1
+8 ;
+9 ;If nothing was returned set Y="-1" so report knows
+10 IF $GET(Y)=-1
SET Y="^"
+11 ;
+12 QUIT Y
+13 ;
+14 ; Enter Date Range
+15 ;
+16 ; Input Variable -> TYPE = 7 CLOSE REPORT
+17 ; 1-6 OTHER REPORTS
+18 ;
+19 ; Return Value -> P1^P2
+20 ;
+21 ; where P1 = From Date
+22 ; = ^ Exit
+23 ; P2 = To Date
+24 ; = blank for Exit
+25 ;
SELDATE(TYPE) NEW BPSIBDT,DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y
+1 SET TYPE=$SELECT($GET(TYPE)=7:"CLOSE",1:"TRANSACTION")
SELDATE1 SET VAL=""
SET DIR(0)="DA^:DT:EX"
SET DIR("A")="START WITH "_TYPE_" DATE: "
SET DIR("B")="T-1"
+1 WRITE !
DO ^DIR
+2 ;
+3 ;Check for "^", timeout, or blank entry
+4 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)!($GET(X)="")
SET VAL="^"
+5 ;
+6 IF VAL=""
Begin DoDot:1
+7 SET $PIECE(VAL,U)=Y
+8 SET DIR(0)="DA^"_VAL_":DT:EX"
SET DIR("A")=" GO TO "_TYPE_" DATE: "
SET DIR("B")="T"
+9 DO ^DIR
+10 ;
+11 ;Check for "^", timeout, or blank entry
+12 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)!($GET(X)="")
SET VAL="^"
QUIT
+13 ;
+14 ;Define Entry
+15 SET $PIECE(VAL,U,2)=Y
End DoDot:1
+16 ;
+17 QUIT VAL
+18 ;
+19 ; Select to Include Open or Closed or All claims
+20 ;
+21 ; Input Variable -> DFLT = 0 = All
+22 ; 1 = Closed
+23 ; 2 = Open
+24 ;
+25 ; Return Value -> 0 = All, 1 = Closed, 2 = Open
SELOPCL(DFLT) NEW DIC,DIR,DIRUT,DUOUT,X,Y
+1 ;
+2 SET DFLT=$SELECT($GET(DFLT)=1:"C",$GET(DFLT)=2:"O",1:"A")
+3 SET DIR(0)="S^O:OPEN;C:CLOSED;A:ALL"
+4 SET DIR("A")="Include (O)pen, (C)losed, or (A)ll Claims"
SET DIR("B")=DFLT
+5 DO ^DIR
+6 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+7 ;
+8 SET Y=$SELECT(Y="C":1,Y="O":2,1:0)
+9 QUIT Y
+10 ;
SELELIG1() ;
+1 ; Select multiple Eligibilities
+2 ;
+3 ; Input Variable -> none
+4 ; Return Value -> 0: All, 1: Selected Eligibilities; '^' = Exit
+5 ;
+6 ; Output Variable -> BPELIG1 = 1 - One or More Eligibilities Selected
+7 ; = 0 - User Entered 'ALL'
+8 ; = "^" - User quit
+9 ;
+10 ; If BPELIG1 = 1 then the BPELIG1 array will be defined where:
+11 ; BPELIG1("C")="CHAMPVA"
+12 ; BPELIG1("T")="TRICARE"
+13 ; BPELIG1("V")="VETERAN"
+14 ;
+15 ;
BPSELIG1 ;
+1 ;Reset BPELIG1 array
+2 KILL BPELIG1
+3 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,P
+4 NEW BPSVTC,BPSERR,BPSVTCSTR,BPSSEL,BPSX
+5 ;
+6 SET BPSVTCSTR=",V,T,C,A,"
+7 SET DIR(0)="FO^0:7"
+8 SET DIR("A",1)=""
+9 SET DIR("A",2)="Select one or more of the following:"
+10 SET DIR("A",3)=""
+11 SET DIR("A",4)=" V VETERAN"
+12 SET DIR("A",5)=" T TRICARE"
+13 SET DIR("A",6)=" C CHAMPVA"
+14 SET DIR("A",7)=" A ALL"
+15 SET DIR("A",8)=""
+16 SET DIR("A")="Display (V)ETERAN or (T)RICARE or (C)HAMPVA or (A)LL"
+17 SET DIR("B")="A"
if $GET(BPARR("ELIG"))'=""
SET DIR("B")=BPARR("ELIG")
+18 SET DIR("?",1)="Enter a single response or multiple responses separated by commas."
+19 SET DIR("?",2)=" Example:"
+20 SET DIR("?",3)=" T"
+21 SET DIR("?")=" T,C"
+22 DO ^DIR
KILL DIR
+23 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)!($DATA(DIRUT))
QUIT "^"
+24 ;
+25 ;Convert any lower case to upper case
+26 SET X=$TRANSLATE(X,BPSLC,BPSUC)
+27 ;
+28 ;If 'A' was one of the selections, reset X to include all available selections.
+29 IF X[","
IF X["A"
SET X="V,T,C"
+30 ;
+31 ; Loop through user input (returned in variable X).
+32 ; Display warning message if any user input selection is not included
+33 ; in the string of acceptable codes (BPSVTCSTR) and re-prompt question.
+34 ; Assign valid selections to BPSVTC array. This array will prevent
+35 ; duplicate entries from being saved to the user's profile.
+36 ;
+37 KILL BPSVTC
+38 SET BPSERR=""
+39 FOR BPSX=1:1:$LENGTH(X,",")
Begin DoDot:1
+40 SET BPSSEL=$PIECE(X,",",BPSX)
+41 IF BPSVTCSTR'[(","_BPSSEL_",")
WRITE !," ",BPSSEL," is not a valid entry."
SET BPSERR=1
QUIT
+42 ; if All was selected don't include in array
+43 IF BPSSEL'="A"
SET BPELIG1(BPSSEL)=$SELECT(BPSSEL="V":"VETERAN",BPSSEL="T":"TRICARE",BPSSEL="C":"CHAMPVA",1:"")
End DoDot:1
+44 ;
+45 IF $GET(BPSERR)=1
GOTO BPSELIG1
+46 ;
+47 ; ALL was selected
+48 IF X="A"
SET BPELIG1=0
+49 ;
IF '$TEST
Begin DoDot:1
+50 ;User selected one or more eligibilities
+51 SET BPELIG1=1
+52 ;
+53 ; Display the user selections
+54 ;
+55 SET BPSSEL=""
+56 FOR
SET BPSSEL=$ORDER(BPELIG1(BPSSEL))
if BPSSEL=""
QUIT
WRITE !,?10,BPELIG1(BPSSEL)
End DoDot:1
+57 ;
+58 QUIT BPELIG1
+59 ;
SELALRC() ;
+1 ; Display Most (R)ecent or (A)ll
+2 ;
+3 ; Return Value -> A: All
+4 ; R: Most Recent
+5 ; ^: Exit
+6 ;
+7 NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT
+8 ;
+9 SET DIR(0)="S^R:Most Recent;A:ALL"
+10 SET DIR("A")="Select Most (R)ecent or (A)ll"
+11 SET DIR("B")="MOST RECENT"
+12 SET DIR("L",1)="Select one of the following:"
+13 SET DIR("L",2)=""
+14 SET DIR("L",3)=" R Most Recent Transaction Only"
+15 SET DIR("L",4)=" A ALL Transactions (will list the Rx/Fill each time resubmitted)"
+16 DO ^DIR
KILL DIR
+17 ;
+18 ;Check for "^" or timeout,
+19 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+20 QUIT Y
+21 ;
SELNBSTS() ;
+1 ; Select the Non-Billable Status Reason
+2 ;
+3 ; Input Variable -> None
+4 ; Return Value -> 0: All, 1: Selected Non-Billable Status; '^' = Exit
+5 ;
+6 ; Output Variable -> BPNBSTS = 1 - One or More Non-Billable Statuses Selected
+7 ; = 0 - User Entered 'ALL'
+8 ; = "" - User quit
+9 ;
+10 ; If BPNBSTS = 1 then the BPNBSTS array will be defined where:
+11 ; BPNBSTS(Non-Billable Status IEN)=Non-Billable Status Reason
+12 ;
+13 ;Reset BPNBSTS array
+14 KILL BPNBSTS
+15 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,P,DIC
+16 ;
+17 ;First see if they want to enter individual eligibilities or ALL
+18 SET DIR(0)="S^S:NON-BILLABLE STATUS;A:ALL"
+19 SET DIR("A")="Select Certain Non-Billable (S)tatus or (A)ll"
+20 SET DIR("B")="ALL"
+21 SET DIR("L",1)="Select one of the following:"
+22 SET DIR("L",2)=""
+23 SET DIR("L",3)=" S NON-BILLABLE STATUS"
+24 SET DIR("L",4)=" A ALL"
+25 DO ^DIR
KILL DIR
+26 ;
+27 ;Check for "^" or timeout, otherwise define BPNBSTS
+28 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+29 SET BPNBSTS=$SELECT(Y="A":0,Y="^":"^",1:1)
+30 IF BPNBSTS'=1
QUIT BPNBSTS
+31 ;
+32 ;Allow user to select multiple non-billable statuses
+33 FOR
Begin DoDot:1
+34 ;Prompt for entry - ICR 6136
+35 KILL X
+36 SET DIC(0)="QEAM"
SET DIC=366.17
SET DIC("A")="Select Non-Billable Reason: "
+37 WRITE !
DO ^DIC
+38 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
QUIT
+39 ;
+40 ;Check for blank entry, quit if no previous selections
+41 IF $GET(Y)=-1
SET Y=$SELECT($DATA(BPNBSTS)>9:"",1:"^")
QUIT
+42 ;
+43 ; Add entry to array or handle duplicate entries
+44 IF '$DATA(BPNBSTS($PIECE(Y,U,1)))
SET BPNBSTS($PIECE(Y,U,1))=$PIECE(Y,U,2)
SET BPNBSTS("B",$PIECE(Y,U,2),$PIECE(Y,U,1))=""
+45 IF '$TEST
Begin DoDot:2
+46 ;Already in the array, so ask whether to delete
+47 NEW P
+48 ;Save Original Value
SET P=Y
+49 SET DIR(0)="S^Y:YES;N:NO"
SET DIR("A")="Delete "_$PIECE(P,U,2)_" from your list?"
+50 SET DIR("B")="NO"
+51 DO ^DIR
+52 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
QUIT
+53 IF Y="Y"
KILL BPNBSTS($PIECE(P,U,1)),BPNBSTS("B",$PIECE(P,U,2),$PIECE(P,U,1))
+54 ;Restore Original Value
SET Y=P
+55 KILL P
End DoDot:2
IF Y="^"
QUIT
+56 ;
+57 ;Display a list of selected values
+58 IF $DATA(BPNBSTS)>9
Begin DoDot:2
+59 NEW X
+60 WRITE !,?2,"Selected:"
+61 SET X=""
FOR
SET X=$ORDER(BPNBSTS("B",X))
if X=""
QUIT
WRITE !,?10,X
+62 KILL X
End DoDot:2
+63 QUIT
End DoDot:1
if Y="^"!(Y="")
QUIT
+64 ;
+65 ; Reset BPNBSTS array if user exited
+66 IF Y="^"
KILL BPNBSTS
SET BPNBSTS="^"
QUIT "^"
+67 ;
+68 ; Deleted 'x-ref' as we don't need to return that
+69 KILL BPNBSTS("B")
+70 ;
+71 QUIT 1
+72 ;
