BPSVRX ;ALB/ESG - View ECME Prescription ;5/23/2011
;;1.0;E CLAIMS MGMT ENGINE;**11,23,37**;JUN 2004;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to $$RXBILL^IBNCPUT3 in ICR #5355
; Reference to RX^PSO52API in ICR #4820
; Reference to $$RXNUM^PSOBPSU2 in ICR #4970
; Reference to DIC^PSODI and DIQ^PSODI in ICR #4858
; Reference to $$CTRL^XMXUTIL1 in ICR #2735
; Reference to $$CJ^XLFSTR, $$LJ^XLFSTR, $$TRIM^XLFSTR, $$UP^XLFSTR in ICR #10104
;
N VALMCNT,VALMQUIT,VALMBG,BPSVRXCLM,DFN,RXIEN,FILL,VIEWTYPE
D EN^VALM("BPS VIEW ECME RX")
K BPSVRX
Q
;
HDR ; -- header code
N DFN,V1,V2,V3,VA,VADM,VAERR
S RXIEN=$G(RXIEN),FILL=$G(FILL)
S V1=$$LJ^XLFSTR("Rx#: "_$$RXNUM^BPSSCRU2(RXIEN)_"/"_FILL,19)
S V1=V1_$$LJ^XLFSTR("ECME#: "_$P($$CLAIM^BPSBUTL(RXIEN,FILL),U,6),21)
S V1=V1_"Drug: "_$E($$RXAPI1^BPSUTIL1(RXIEN,6),1,34)
S VALMHDR(1)=V1
;
S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
D DEM^VADPT
S V2=$$LJ^XLFSTR("Patient: "_$E($G(VADM(1)),1,30)_" ("_$G(VA("BID"))_")",48)
S $E(V2,57)=$$LJ^XLFSTR("DOB: "_$$FMTE^XLFDT($P($G(VADM(3)),U,1),"2Z")_" ("_$G(VADM(4))_")",22)
S VALMHDR(2)=V2
;
S V3=$$LJ^XLFSTR("Birth Sex: "_$P($G(VADM(5)),U,1),8)
S $E(V3,32)="Self-Identified Gender: "_$E($P($G(VADM(14,5)),U,1),1,24)
S VALMHDR(3)=V3
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- ListManager exit code
K ^TMP("BPSVRX",$J)
Q
;
INIT(BPSVRX) ; ListManager entry point
N BPSVRXQ,BPSFL
;
; Array entries may or may not be set-up by external calling applications.
;
; BPSVRX("RXIEN") - Rx ien
; BPSVRX("FILL#") - fill#
;
; All array entries are optional. If not defined, then the system will prompt the user. First thing to do
; is figure out what data is defined upon entry to this routine.
;
; check Rx
S RXIEN=+$G(BPSVRX("RXIEN"))
I 'RXIEN K BPSVRX G INIT1 ; no Rx
I $$RXAPI1^BPSUTIL1(RXIEN,.01,"E")="" K BPSVRX G INIT1 ; invalid Rx
S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
I 'DFN K BPSVRX,DFN G INIT1 ; invalid patient ien
;
; RXIEN is good, check fill#
S FILL=$G(BPSVRX("FILL#"))
I FILL="" G INIT2 ; rx is OK, fill# is not known
I FILL=0 G INIT3 ; rx is OK, original fill OK
I $$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILL,.01,"I") G INIT3 ; fill OK - fill date found in 52.1
D RFL(RXIEN,.BPSFL) I $D(BPSFL(FILL)) G INIT3 ; fill OK - found in BPS Transaction
;
; fill# is not valid so prompt for it
G INIT2
;
;-------------------------------------------------
;
INIT1 ; internal branch point to perform all prompts (Rx, fill#, view type)
S RXIEN=$$RXP()
I $G(BPSVRXQ) S VALMQUIT=1 G INITX
S DFN=+$P(RXIEN,U,2),RXIEN=+$P(RXIEN,U,1)
I 'RXIEN!'DFN S VALMQUIT=1 G INITX
;
INIT2 ; internal branch point for fill# prompt and view type prompt
S FILL=$$FILLP(RXIEN,DFN)
I $G(BPSVRXQ) S VALMQUIT=1 G INITX
I FILL="" S VALMQUIT=1 G INITX
;
INIT3 ; internal branch point for view type prompt
S VIEWTYPE=$$VTP(RXIEN,FILL)
I $G(BPSVRXQ) S VALMQUIT=1 G INITX
I VIEWTYPE'="M",VIEWTYPE'="A" S VALMQUIT=1 G INITX
;
; Build list
D BUILD(RXIEN,FILL,VIEWTYPE)
;
INITX ; finished with the INIT code to initially build the list
Q
;
RXP() ; prompt the user to enter the prescription
; output value of function is RXIEN^DFN
; return BPSVRXQ=1 to exit option
;
N RXIEN,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIC,DR,DA,D0,DIQ,BPSRXD,PSODIY,RXN,DFN,PNM,DRUG,RXST
RXPR ;
S RXIEN="",DFN=""
S DIR(0)="FAO"
S DIR("A")="Select Prescription: "
S DIR("?",1)=" A prescription number or ECME number may be entered. To look-up a"
S DIR("?",2)=" prescription by the ECME number, please enter ""E."" followed by the ECME"
S DIR("?")=" number with or without any leading zeros."
W ! D ^DIR K DIR
I X=""!$D(DIRUT) S BPSVRXQ=1 G RXPX
S X=$$UP^XLFSTR(X)
;
; ECME# lookup
I $E(X,1,2)="E." S RXIEN=+$$RXNUM^PSOBPSU2($E(X,3,$L(X))) G RXP1 ; DBIA #4970
;
; Rx# lookup
S DIC=52
S DIC(0)="E"
S DIC("S")="I $P($G(^(0)),U,2),$D(^(""STA"")),$P($G(^(""STA"")),U,1)'=13"
W ! D DIC^PSODI(52,.DIC,X) K DIC ; DBIA# 4858
S RXIEN=+Y
;
RXP1 ;
;
I RXIEN'>0 W " Invalid selection. Please try again.",$C(7) G RXPR ; start over
;
; Display Rx data and get confirmation to proceed
S DIC=52,DR=".01;2;6;100",DA=RXIEN,DIQ="BPSRXD",DIQ(0)="IE"
D DIQ^PSODI(52,DIC,DR,DA,.DIQ) ; DBIA# 4858
S RXN=$G(BPSRXD(52,DA,.01,"E"))
S DFN=+$G(BPSRXD(52,DA,2,"I"))
S PNM=$G(BPSRXD(52,DA,2,"E"))
S DRUG=$G(BPSRXD(52,DA,6,"E"))
S RXST=$G(BPSRXD(52,DA,100,"E"))
W !!?1,"Patient",?25,"Rx#",?37,"Drug Name",?63,"Rx Status"
W !?1,$E(PNM,1,23),?25,RXN,?37,$E(DRUG,1,25),?63,$E(RXST,1,16),!
;
I $$YESNO^BPSSCRRS("OK to continue","Yes")<1 G RXPR ; start over
;
RXPX ;
Q RXIEN_U_DFN
;
FILLP(RXIEN,DFN) ; prompt for a fill# given the RXIEN and DFN
; return BPSVRXQ=1 to exit option
;
N FILL,BPFLZ,RF,FLDT,RELDT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,CNT,BSTR,BPSFL
S FILL=""
I '$G(RXIEN)!'$G(DFN) G FILLX
;
K ^TMP($J,"BPSP"),BPFLZ
D RX^PSO52API(DFN,"BPSP",RXIEN,,"2,R") ; DBIA# 4820
S RF=0 F S RF=$O(^TMP($J,"BPSP",DFN,RXIEN,"RF",RF)) Q:'RF D
. S FLDT=+$G(^TMP($J,"BPSP",DFN,RXIEN,"RF",RF,.01))\1 ; fill date
. S RELDT=+$G(^TMP($J,"BPSP",DFN,RXIEN,"RF",RF,17))\1 ; release date
. S BPFLZ(RF)=FLDT_U_RELDT
. Q
;
; add original fill date and original release date to local array
S FLDT=+$G(^TMP($J,"BPSP",DFN,RXIEN,22))\1 ; original fill date
S RELDT=+$G(^TMP($J,"BPSP",DFN,RXIEN,31))\1 ; original release date
S BPFLZ(0)=FLDT_U_RELDT
;
; check for any deleted fills that have ECME activity
D RFL(RXIEN,.BPSFL)
S RF="" F S RF=$O(BPSFL(RF)) Q:RF="" I '$D(BPFLZ(RF)) S BPFLZ(RF)=0_U_0
;
S DIR(0)="S"
S DIR("L",1)="Rx# "_$G(^TMP($J,"BPSP",DFN,RXIEN,.01))_" has the following fills:"
S DIR("L",2)=""
S DIR("L",3)=" Fill# Fill Date Release Date"
S DIR("L",4)=" ----- ---------- ------------"
S CNT=0,BSTR=""
S RF="" F S RF=$O(BPFLZ(RF)) Q:RF="" D
. S CNT=CNT+1
. S FLDT=$$FMTE^XLFDT($P(BPFLZ(RF),U,1),"5Z") I 'FLDT S FLDT=" - "
. S RELDT=$$FMTE^XLFDT($P(BPFLZ(RF),U,2),"5Z") I 'RELDT S RELDT=" - "
. I 'FLDT,'RELDT S (FLDT,RELDT)=" Deleted "
. S $P(BSTR,";",CNT)=RF_":"_FLDT_" "_RELDT
. S DIR("L",CNT+4)=$J(RF,7)_" "_FLDT_" "_RELDT
. Q
S DIR("L")=" "
S $P(DIR(0),U,2)=BSTR
S DIR("A")="Select Fill Number"
I CNT=1 D
. S DIR("B")=$O(BPFLZ("")) ; default if there is only 1 fill
. S $P(DIR("L",1)," ",$L(DIR("L",1)," "))="fill:" ; singular
. Q
W ! D ^DIR K DIR
I Y=""!$D(DIRUT) S BPSVRXQ=1 G FILLX
S FILL=Y
;
FILLX ;
K ^TMP($J,"BPSP")
Q FILL
;
VTP(RXIEN,FILL) ; prompt for the view type of this report
; Most recent ECME transaction or All ECME transactions
; Output value of function is "M" or "A".
; return BPSVRXQ=1 to exit option
;
N VIEWTYPE,TOT,COB,IEN59,BP57,T1,T2,T3,MTXT,ATXT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
N BPSVRXIB,IBIFN,IBC,IBA,IB,BPSVRXCAN
S VIEWTYPE=""
I '$G(RXIEN) G VTPX
I $G(FILL)="" G VTPX
;
; count up the number of ECME transactions on file (total and by COB)
K TOT
F COB=1:1:3 S IEN59=$$IEN59^BPSOSRX(RXIEN,FILL,COB) D
. I IEN59="" Q
. S BP57=0 F S BP57=$O(^BPSTL("B",IEN59,BP57)) Q:'BP57 S TOT=$G(TOT)+1,TOT(COB)=$G(TOT(COB))+1
. Q
S TOT=+$G(TOT),T1=+$G(TOT(1)),T2=+$G(TOT(2)),T3=+$G(TOT(3))
;
; if 0 ECME transactions found, then no need to ask this next question
I TOT=0 S VIEWTYPE="M" G VTPCB
;
S DIR(0)="S"
I TOT=1 S DIR("A",1)=" There is 1 ECME transaction for this Rx/fill."
E S DIR("A",1)=" There are "_TOT_" ECME transactions for this Rx/fill."
S DIR("A",2)=" "
I T2!T3 S DIR("A",2)=" "_T1_" for the primary payer"_$S(T2:", "_T2_" for the secondary payer",1:"")_$S(T3:", "_T3_" for the tertiary payer",1:"")_".",DIR("A",3)=" "
S MTXT="Most recent transaction"_$S(T2!T3:" for each payer",1:"")
S ATXT="All transactions"
S DIR("A")="Select "_MTXT_" or "_ATXT
S DIR("B")="M"
S $P(DIR(0),U,2)="M:"_MTXT_";A:"_ATXT
W ! D ^DIR K DIR
I Y=""!$D(DIRUT) S BPSVRXQ=1 G VTPX
S VIEWTYPE=Y
;
VTPCB ;
; check for cancelled bills and ask how they should be handled
K BPSVRXCLM
I $$RXBILL^IBNCPUT3(RXIEN,FILL,"","",.BPSVRXIB) ; build a list of all bills for Rx/fill# (IA #5355)
S (IBIFN,IBC,IBA)=0 F S IBIFN=$O(BPSVRXIB(IBIFN)) Q:'IBIFN D
. S IB=$G(BPSVRXIB(IBIFN))
. I $P(IB,U,8)=7!($P(IB,U,2)="CB")!($P(IB,U,2)="CN") S IBC=IBC+1,BPSVRXCLM(IBIFN)=0 Q ; cancelled bill
. S IBA=IBA+1 ; non-cancelled bill
. S BPSVRXCLM(IBIFN)=1
. Q
S BPSVRXCLM=IBA+IBC
;
I IBC=0 G VTPX ; no cancelled bills found so no further questions
;
I IBC,IBA S DIR("A",1)=" "_IBA_" non-cancelled bill"_$S(IBA=1:"",1:"s")_" and "_IBC_" cancelled bill"_$S(IBC=1:"",1:"s")_" exist for this Rx/fill."
I IBC,'IBA S DIR("A",1)=" "_IBC_" cancelled bill"_$S(IBC=1:"",1:"s")_", but no active bills exist for this Rx/fill."
I IBA S DIR("A",2)=" The non-cancelled bill"_$S(IBA=1:"",1:"s")_" will automatically be included.",DIR("A",3)=" "
I 'IBA S DIR("A",2)=" "
S DIR("A")="Do you want to include the cancelled bill"_$S(IBC=1:"",1:"s")
S DIR("B")="No"
S DIR(0)="Y"
W ! D ^DIR K DIR
I Y=""!$D(DIRUT) S BPSVRXQ=1 G VTPX
S BPSVRXCAN=Y
;
; If the user wants cancelled bills, then no changes to the BPSVRXCLM list are needed so get out
I BPSVRXCAN G VTPX
;
; If the user does not want cancelled bills, then remove them from the BPSVRXCLM list
S IBIFN=0 F S IBIFN=$O(BPSVRXCLM(IBIFN)) Q:'IBIFN I 'BPSVRXCLM(IBIFN) K BPSVRXCLM(IBIFN)
S BPSVRXCLM=IBA
;
VTPX ;
Q VIEWTYPE
;
BUILD(RXIEN,FILL,VIEWTYPE) ; build list
; This is called in the INIT section to build the ListMan scratch global
; all parameters are required and must exist when this is called
;
S BPSVRX=1 ; special variable indicating this is the driver routine
I '$D(ZTQUEUED) W !
K ^TMP("BPSVRX",$J) ; initialize display array
;
D VIEWRX^BPSVRX1(RXIEN,FILL,VIEWTYPE,1) ; View Prescriptions [PSO VIEW]
D LOG^BPSVRX1(RXIEN,FILL,VIEWTYPE,2) ; ECME Print Claim Log
D BILL^BPSVRX1(RXIEN,FILL,VIEWTYPE,3) ; IB ECME Billing Events Report
; Comment out SD until US1401 is coded
; D SD^BPSVRX3(RXIEN,FILL,VIEWTYPE,4) ; SD Sensitive Drug
D CRI^BPSVRX1(RXIEN,FILL,VIEWTYPE,5) ; ECME Claims-Response Inquiry Report
D INS^BPSVRX1(RXIEN,FILL,VIEWTYPE,6) ; View Pharmacy Insurance policies
D TPJILST^BPSVRX1(RXIEN,FILL,VIEWTYPE,7) ; List of TPJI-eligible bills
D MP^BPSVRX3(RXIEN,FILL,VIEWTYPE,8) ; MP Medication Profile
D TPJICI^BPSVRX1(RXIEN,FILL,VIEWTYPE,9) ; TPJI - Claim Information
D TPJIARP^BPSVRX1(RXIEN,FILL,VIEWTYPE,10) ; TPJI - AR Account Profile
D TPJIARCH^BPSVRX1(RXIEN,FILL,VIEWTYPE,11) ; TPJI - AR Comment History
D TPJIECME^BPSVRX1(RXIEN,FILL,VIEWTYPE,12) ; TPJI - ECME Rx Response Info
D DGELST^BPSVRX2(RXIEN,FILL,VIEWTYPE,13) ; View Registration Elig Status
D DGELV^BPSVRX2(RXIEN,FILL,VIEWTYPE,14) ; View Registration Elig Verification
;
BUILDX ;
Q
;
NAV(SNUM) ; ListMan nav jumping
S VALMBG=$G(BPSVRX("LISTNAV",SNUM),1) ; default to 1 if not defined
NAVX ;
Q
;
UPDATE(DISP,HDR,TITLE,NAME,SNUM) ; update the BPSVRX ListMan display array
; DISP - display array to be merged into ^TMP("BPSVRX",$J)
; Assmues display lines are found in @DISP@(N,0)
; HDR - header data array (i.e. VALMHDR data); HDR(1)=line 1; HDR(2)=line 2; etc.
; TITLE - title of section (i.e. VALM("TITLE")
; NAME - name/description of section being added (required)
; SNUM - section number used for ListMan navigational jumps (required)
;
N LN,Z,NODATA,BPSVID
;
S LN=+$O(^TMP("BPSVRX",$J,""),-1) ; last line# used in display array
;
; display name of section centered and reverse video
I $G(NAME)'="" D
. S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=$$CJ^XLFSTR(NAME,80)
. D CNTRL^VALM10(LN,1,80,IORVON,IORVOFF) ; reverse video line
. I '$D(BPSVRX("LISTNAV",SNUM)) S BPSVRX("LISTNAV",SNUM)=LN ; store 1st line# of each section
. Q
;
; merge in the ListMan title if one exists
I $G(TITLE)'="" D
. S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=$$FLN(LN,TITLE)
. D CNTRL^VALM10(LN,1,80,IOUON,IOUOFF) ; display a line under the title
. Q
;
; merge in header data if this array exists
I $O(HDR(0)) D
. S Z=0 F S Z=$O(HDR(Z)) Q:'Z S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=$$FLN(LN,$G(HDR(Z)))
. D CNTRL^VALM10(LN,1,80,IOUON,IOUOFF) ; display a line under the header data
. Q
;
; merge in display array
S BPSVID="VALM VIDEO"
I DISP="" S DISP="NODATA"
S Z=0 F S Z=$O(@DISP@(Z)) Q:'Z S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=$G(@DISP@(Z,0)) D
. ; check for video attributes to be duplicated
. I '$D(^TMP(BPSVID,$J,999,Z)) Q ; no video attributes on this line
. M ^TMP(BPSVID,$J,VALMEVL,LN)=^TMP(BPSVID,$J,999,Z) ; copy video attributes
. K ^TMP(BPSVID,$J,999,Z) ; clean-up
. Q
;
; display a message if no data found for this section
I '$O(@DISP@(0)) D
. S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=" "
. S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=" <No data found for this section>"
. S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=" "
. Q
;
; update the number of lines in the list
S VALMCNT=LN
;
UPDX ;
Q
;
FLN(LINE,DATA) ; format line# LINE by reproducing any video attributes found in string DATA
N VARON,VAROFF,FINDON,FINDOFF,COL,WIDTH
;
F VARON="IOBON","IORVON","IOUON","IOINHI" D ; on attribute
. S VAROFF=$S(VARON="IOBON":"IOBOFF",VARON="IORVON":"IORVOFF",VARON="IOUON":"IOUOFF",1:"IOINORM") ; off attribute
. F S FINDON=$F(DATA,@VARON) Q:'FINDON D
.. S COL=FINDON-$L(@VARON) ; starting column for video attribute
.. S FINDOFF=$F(DATA,@VAROFF) ; see if off attribute is also found
.. I FINDOFF S WIDTH=FINDOFF-COL-$L(@VARON)-$L(@VAROFF) ; width of affected text between on and off attributes
.. I 'FINDOFF S WIDTH=$L(DATA)-COL-$L(@VARON) ; width of affected text (thru the end of the string)
.. D CNTRL^VALM10(LINE,COL,WIDTH,@VARON,@VAROFF) ; save the video attribute using Listman API
.. S DATA=$P(DATA,@VARON,1)_$P(DATA,@VARON,2,999) ; remove 1st on attribute
.. I FINDOFF S DATA=$P(DATA,@VAROFF,1)_$P(DATA,@VAROFF,2,999) ; remove 1st off attribute
.. Q
. Q
I DATA="" S DATA=" " ; blank lines need to be non-nil so video attributes may exist for them
FLNX ;
Q DATA
;
HFS(SECTION,RTN,VRXHDR,HDRARY,BPSVRXKQ) ; output data to scratch host file and merge into ListMan display array
; SECTION - section code (e.g. "BER" - billing events report, "CRI" - claims-response inquiry)
; RTN - tag^routine to invoke to produce the report
; VRXHDR - name of section to appear at the start of the display
; HDRARY - header array
; BPSVRXKQ - section#
;
N BPSHANDLE,BPSVDIR,BPSVFILE,HDR,POP,GLO,BPSARR,BVZ,BV1
;
; create a host file to write the data
S SECTION="BPSVRX_"_$G(SECTION)
S BPSHANDLE=SECTION_"_"_$J
S BPSVDIR=$$DEFDIR^%ZISH()
S BPSVFILE=BPSHANDLE_".RPT"
I BPSVDIR="" D G HFSX
. S HDR(1)="Error: Default directory is blank."
. S HDR(2)="Please define one in the KERNEL SYSTEM PARAMETERS."
. D UPDATE("",.HDR,"",VRXHDR,BPSVRXKQ)
. Q
;
D OPEN^%ZISH(BPSHANDLE,BPSVDIR,BPSVFILE,"W")
I POP D G HFSX
. S HDR(1)="Error: Unable to open scratch data file for writing."
. S HDR(2)="Directory="_BPSVDIR
. S HDR(3)="Filename="_BPSVFILE
. D UPDATE("",.HDR,"",VRXHDR,BPSVRXKQ)
. Q
;
U IO ; use the file
S IOM=80,IOSL=100000 ; 80 char width and long screen
D @RTN ; create the report
D CLOSE^%ZISH(BPSHANDLE) ; close the data file
;
; move contents of scratch data file to scratch global
S GLO=$NA(^TMP($J,SECTION,1,0))
K ^TMP($J,SECTION)
I '$$FTG^%ZISH(BPSVDIR,BPSVFILE,GLO,3) D G HFSX
. S HDR(1)="Error: Unable to read in the contents of the scratch data file."
. S HDR(2)="Directory="_BPSVDIR
. S HDR(3)="Filename="_BPSVFILE
. S HDR(4)="Destination="_GLO
. D UPDATE("",.HDR,"",VRXHDR,BPSVRXKQ)
. Q
;
; delete the scratch data file
S BPSARR(BPSVFILE)=""
I $$DEL^%ZISH(BPSVDIR,$NA(BPSARR))
;
; remove "PAGE 1" line from the beginning of the display data
F BVZ=1:1:10 I $$TRIM^XLFSTR($G(^TMP($J,SECTION,BVZ,0)))="PAGE 1" K ^TMP($J,SECTION,BVZ,0)
;
; remove all control characters and trailing spaces from all lines
S BVZ=0 F S BVZ=$O(^TMP($J,SECTION,BVZ)) Q:'BVZ S BV1=$G(^TMP($J,SECTION,BVZ,0)),BV1=$$CTRL^XMXUTIL1(BV1),BV1=$$TRIM^XLFSTR(BV1,"R"),^TMP($J,SECTION,BVZ,0)=BV1 ; DBIAs #2735, #10104
;
; update BPSVRX display array
S GLO=$NA(^TMP($J,SECTION))
D UPDATE(GLO,.HDRARY,"",VRXHDR,BPSVRXKQ)
K ^TMP($J,SECTION) ; clean up scratch global
;
HFSX ;
Q
;
RFL(RXIEN,FILLIST) ; Return a list of all ECME fill#s for the Rx
N BP59,FL
K FILLIST
S RXIEN=+$G(RXIEN) I 'RXIEN G RFLX
S BP59=RXIEN F S BP59=$O(^BPST(BP59)) Q:$P(BP59,".",1)'=RXIEN S FL=$P($G(^BPST(BP59,1)),U,1) I FL'="" S FILLIST(FL)=BP59
RFLX ;
Q
;
VER ; Selection from the ECME User Screen
N BPSG,RXREF,BPSVRX
D FULL^VALM1
W !,"Enter the claim line number for the View ePharmacy Rx report."
S BPSG=$$ASKLINE^BPSSCRU4("Select item","C","Please select SINGLE Rx Line.")
I BPSG<1 G VERX
S RXREF=$$RXREF^BPSSCRU2(+$P(BPSG,U,4))
S BPSVRX("RXIEN")=$P(RXREF,U,1)
S BPSVRX("FILL#")=$P(RXREF,U,2)
D ^BPSVRX
VERX ;
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSVRX 17650 printed Oct 16, 2024@17:54:27 Page 2
BPSVRX ;ALB/ESG - View ECME Prescription ;5/23/2011
+1 ;;1.0;E CLAIMS MGMT ENGINE;**11,23,37**;JUN 2004;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to $$RXBILL^IBNCPUT3 in ICR #5355
+5 ; Reference to RX^PSO52API in ICR #4820
+6 ; Reference to $$RXNUM^PSOBPSU2 in ICR #4970
+7 ; Reference to DIC^PSODI and DIQ^PSODI in ICR #4858
+8 ; Reference to $$CTRL^XMXUTIL1 in ICR #2735
+9 ; Reference to $$CJ^XLFSTR, $$LJ^XLFSTR, $$TRIM^XLFSTR, $$UP^XLFSTR in ICR #10104
+10 ;
+11 NEW VALMCNT,VALMQUIT,VALMBG,BPSVRXCLM,DFN,RXIEN,FILL,VIEWTYPE
+12 DO EN^VALM("BPS VIEW ECME RX")
+13 KILL BPSVRX
+14 QUIT
+15 ;
HDR ; -- header code
+1 NEW DFN,V1,V2,V3,VA,VADM,VAERR
+2 SET RXIEN=$GET(RXIEN)
SET FILL=$GET(FILL)
+3 SET V1=$$LJ^XLFSTR("Rx#: "_$$RXNUM^BPSSCRU2(RXIEN)_"/"_FILL,19)
+4 SET V1=V1_$$LJ^XLFSTR("ECME#: "_$PIECE($$CLAIM^BPSBUTL(RXIEN,FILL),U,6),21)
+5 SET V1=V1_"Drug: "_$EXTRACT($$RXAPI1^BPSUTIL1(RXIEN,6),1,34)
+6 SET VALMHDR(1)=V1
+7 ;
+8 SET DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
+9 DO DEM^VADPT
+10 SET V2=$$LJ^XLFSTR("Patient: "_$EXTRACT($GET(VADM(1)),1,30)_" ("_$GET(VA("BID"))_")",48)
+11 SET $EXTRACT(V2,57)=$$LJ^XLFSTR("DOB: "_$$FMTE^XLFDT($PIECE($GET(VADM(3)),U,1),"2Z")_" ("_$GET(VADM(4))_")",22)
+12 SET VALMHDR(2)=V2
+13 ;
+14 SET V3=$$LJ^XLFSTR("Birth Sex: "_$PIECE($GET(VADM(5)),U,1),8)
+15 SET $EXTRACT(V3,32)="Self-Identified Gender: "_$EXTRACT($PIECE($GET(VADM(14,5)),U,1),1,24)
+16 SET VALMHDR(3)=V3
+17 QUIT
+18 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- ListManager exit code
+1 KILL ^TMP("BPSVRX",$JOB)
+2 QUIT
+3 ;
INIT(BPSVRX) ; ListManager entry point
+1 NEW BPSVRXQ,BPSFL
+2 ;
+3 ; Array entries may or may not be set-up by external calling applications.
+4 ;
+5 ; BPSVRX("RXIEN") - Rx ien
+6 ; BPSVRX("FILL#") - fill#
+7 ;
+8 ; All array entries are optional. If not defined, then the system will prompt the user. First thing to do
+9 ; is figure out what data is defined upon entry to this routine.
+10 ;
+11 ; check Rx
+12 SET RXIEN=+$GET(BPSVRX("RXIEN"))
+13 ; no Rx
IF 'RXIEN
KILL BPSVRX
GOTO INIT1
+14 ; invalid Rx
IF $$RXAPI1^BPSUTIL1(RXIEN,.01,"E")=""
KILL BPSVRX
GOTO INIT1
+15 SET DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
+16 ; invalid patient ien
IF 'DFN
KILL BPSVRX,DFN
GOTO INIT1
+17 ;
+18 ; RXIEN is good, check fill#
+19 SET FILL=$GET(BPSVRX("FILL#"))
+20 ; rx is OK, fill# is not known
IF FILL=""
GOTO INIT2
+21 ; rx is OK, original fill OK
IF FILL=0
GOTO INIT3
+22 ; fill OK - fill date found in 52.1
IF $$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILL,.01,"I")
GOTO INIT3
+23 ; fill OK - found in BPS Transaction
DO RFL(RXIEN,.BPSFL)
IF $DATA(BPSFL(FILL))
GOTO INIT3
+24 ;
+25 ; fill# is not valid so prompt for it
+26 GOTO INIT2
+27 ;
+28 ;-------------------------------------------------
+29 ;
INIT1 ; internal branch point to perform all prompts (Rx, fill#, view type)
+1 SET RXIEN=$$RXP()
+2 IF $GET(BPSVRXQ)
SET VALMQUIT=1
GOTO INITX
+3 SET DFN=+$PIECE(RXIEN,U,2)
SET RXIEN=+$PIECE(RXIEN,U,1)
+4 IF 'RXIEN!'DFN
SET VALMQUIT=1
GOTO INITX
+5 ;
INIT2 ; internal branch point for fill# prompt and view type prompt
+1 SET FILL=$$FILLP(RXIEN,DFN)
+2 IF $GET(BPSVRXQ)
SET VALMQUIT=1
GOTO INITX
+3 IF FILL=""
SET VALMQUIT=1
GOTO INITX
+4 ;
INIT3 ; internal branch point for view type prompt
+1 SET VIEWTYPE=$$VTP(RXIEN,FILL)
+2 IF $GET(BPSVRXQ)
SET VALMQUIT=1
GOTO INITX
+3 IF VIEWTYPE'="M"
IF VIEWTYPE'="A"
SET VALMQUIT=1
GOTO INITX
+4 ;
+5 ; Build list
+6 DO BUILD(RXIEN,FILL,VIEWTYPE)
+7 ;
INITX ; finished with the INIT code to initially build the list
+1 QUIT
+2 ;
RXP() ; prompt the user to enter the prescription
+1 ; output value of function is RXIEN^DFN
+2 ; return BPSVRXQ=1 to exit option
+3 ;
+4 NEW RXIEN,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIC,DR,DA,D0,DIQ,BPSRXD,PSODIY,RXN,DFN,PNM,DRUG,RXST
RXPR ;
+1 SET RXIEN=""
SET DFN=""
+2 SET DIR(0)="FAO"
+3 SET DIR("A")="Select Prescription: "
+4 SET DIR("?",1)=" A prescription number or ECME number may be entered. To look-up a"
+5 SET DIR("?",2)=" prescription by the ECME number, please enter ""E."" followed by the ECME"
+6 SET DIR("?")=" number with or without any leading zeros."
+7 WRITE !
DO ^DIR
KILL DIR
+8 IF X=""!$DATA(DIRUT)
SET BPSVRXQ=1
GOTO RXPX
+9 SET X=$$UP^XLFSTR(X)
+10 ;
+11 ; ECME# lookup
+12 ; DBIA #4970
IF $EXTRACT(X,1,2)="E."
SET RXIEN=+$$RXNUM^PSOBPSU2($EXTRACT(X,3,$LENGTH(X)))
GOTO RXP1
+13 ;
+14 ; Rx# lookup
+15 SET DIC=52
+16 SET DIC(0)="E"
+17 SET DIC("S")="I $P($G(^(0)),U,2),$D(^(""STA"")),$P($G(^(""STA"")),U,1)'=13"
+18 ; DBIA# 4858
WRITE !
DO DIC^PSODI(52,.DIC,X)
KILL DIC
+19 SET RXIEN=+Y
+20 ;
RXP1 ;
+1 ;
+2 ; start over
IF RXIEN'>0
WRITE " Invalid selection. Please try again.",$CHAR(7)
GOTO RXPR
+3 ;
+4 ; Display Rx data and get confirmation to proceed
+5 SET DIC=52
SET DR=".01;2;6;100"
SET DA=RXIEN
SET DIQ="BPSRXD"
SET DIQ(0)="IE"
+6 ; DBIA# 4858
DO DIQ^PSODI(52,DIC,DR,DA,.DIQ)
+7 SET RXN=$GET(BPSRXD(52,DA,.01,"E"))
+8 SET DFN=+$GET(BPSRXD(52,DA,2,"I"))
+9 SET PNM=$GET(BPSRXD(52,DA,2,"E"))
+10 SET DRUG=$GET(BPSRXD(52,DA,6,"E"))
+11 SET RXST=$GET(BPSRXD(52,DA,100,"E"))
+12 WRITE !!?1,"Patient",?25,"Rx#",?37,"Drug Name",?63,"Rx Status"
+13 WRITE !?1,$EXTRACT(PNM,1,23),?25,RXN,?37,$EXTRACT(DRUG,1,25),?63,$EXTRACT(RXST,1,16),!
+14 ;
+15 ; start over
IF $$YESNO^BPSSCRRS("OK to continue","Yes")<1
GOTO RXPR
+16 ;
RXPX ;
+1 QUIT RXIEN_U_DFN
+2 ;
FILLP(RXIEN,DFN) ; prompt for a fill# given the RXIEN and DFN
+1 ; return BPSVRXQ=1 to exit option
+2 ;
+3 NEW FILL,BPFLZ,RF,FLDT,RELDT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,CNT,BSTR,BPSFL
+4 SET FILL=""
+5 IF '$GET(RXIEN)!'$GET(DFN)
GOTO FILLX
+6 ;
+7 KILL ^TMP($JOB,"BPSP"),BPFLZ
+8 ; DBIA# 4820
DO RX^PSO52API(DFN,"BPSP",RXIEN,,"2,R")
+9 SET RF=0
FOR
SET RF=$ORDER(^TMP($JOB,"BPSP",DFN,RXIEN,"RF",RF))
if 'RF
QUIT
Begin DoDot:1
+10 ; fill date
SET FLDT=+$GET(^TMP($JOB,"BPSP",DFN,RXIEN,"RF",RF,.01))\1
+11 ; release date
SET RELDT=+$GET(^TMP($JOB,"BPSP",DFN,RXIEN,"RF",RF,17))\1
+12 SET BPFLZ(RF)=FLDT_U_RELDT
+13 QUIT
End DoDot:1
+14 ;
+15 ; add original fill date and original release date to local array
+16 ; original fill date
SET FLDT=+$GET(^TMP($JOB,"BPSP",DFN,RXIEN,22))\1
+17 ; original release date
SET RELDT=+$GET(^TMP($JOB,"BPSP",DFN,RXIEN,31))\1
+18 SET BPFLZ(0)=FLDT_U_RELDT
+19 ;
+20 ; check for any deleted fills that have ECME activity
+21 DO RFL(RXIEN,.BPSFL)
+22 SET RF=""
FOR
SET RF=$ORDER(BPSFL(RF))
if RF=""
QUIT
IF '$DATA(BPFLZ(RF))
SET BPFLZ(RF)=0_U_0
+23 ;
+24 SET DIR(0)="S"
+25 SET DIR("L",1)="Rx# "_$GET(^TMP($JOB,"BPSP",DFN,RXIEN,.01))_" has the following fills:"
+26 SET DIR("L",2)=""
+27 SET DIR("L",3)=" Fill# Fill Date Release Date"
+28 SET DIR("L",4)=" ----- ---------- ------------"
+29 SET CNT=0
SET BSTR=""
+30 SET RF=""
FOR
SET RF=$ORDER(BPFLZ(RF))
if RF=""
QUIT
Begin DoDot:1
+31 SET CNT=CNT+1
+32 SET FLDT=$$FMTE^XLFDT($PIECE(BPFLZ(RF),U,1),"5Z")
IF 'FLDT
SET FLDT=" - "
+33 SET RELDT=$$FMTE^XLFDT($PIECE(BPFLZ(RF),U,2),"5Z")
IF 'RELDT
SET RELDT=" - "
+34 IF 'FLDT
IF 'RELDT
SET (FLDT,RELDT)=" Deleted "
+35 SET $PIECE(BSTR,";",CNT)=RF_":"_FLDT_" "_RELDT
+36 SET DIR("L",CNT+4)=$JUSTIFY(RF,7)_" "_FLDT_" "_RELDT
+37 QUIT
End DoDot:1
+38 SET DIR("L")=" "
+39 SET $PIECE(DIR(0),U,2)=BSTR
+40 SET DIR("A")="Select Fill Number"
+41 IF CNT=1
Begin DoDot:1
+42 ; default if there is only 1 fill
SET DIR("B")=$ORDER(BPFLZ(""))
+43 ; singular
SET $PIECE(DIR("L",1)," ",$LENGTH(DIR("L",1)," "))="fill:"
+44 QUIT
End DoDot:1
+45 WRITE !
DO ^DIR
KILL DIR
+46 IF Y=""!$DATA(DIRUT)
SET BPSVRXQ=1
GOTO FILLX
+47 SET FILL=Y
+48 ;
FILLX ;
+1 KILL ^TMP($JOB,"BPSP")
+2 QUIT FILL
+3 ;
VTP(RXIEN,FILL) ; prompt for the view type of this report
+1 ; Most recent ECME transaction or All ECME transactions
+2 ; Output value of function is "M" or "A".
+3 ; return BPSVRXQ=1 to exit option
+4 ;
+5 NEW VIEWTYPE,TOT,COB,IEN59,BP57,T1,T2,T3,MTXT,ATXT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+6 NEW BPSVRXIB,IBIFN,IBC,IBA,IB,BPSVRXCAN
+7 SET VIEWTYPE=""
+8 IF '$GET(RXIEN)
GOTO VTPX
+9 IF $GET(FILL)=""
GOTO VTPX
+10 ;
+11 ; count up the number of ECME transactions on file (total and by COB)
+12 KILL TOT
+13 FOR COB=1:1:3
SET IEN59=$$IEN59^BPSOSRX(RXIEN,FILL,COB)
Begin DoDot:1
+14 IF IEN59=""
QUIT
+15 SET BP57=0
FOR
SET BP57=$ORDER(^BPSTL("B",IEN59,BP57))
if 'BP57
QUIT
SET TOT=$GET(TOT)+1
SET TOT(COB)=$GET(TOT(COB))+1
+16 QUIT
End DoDot:1
+17 SET TOT=+$GET(TOT)
SET T1=+$GET(TOT(1))
SET T2=+$GET(TOT(2))
SET T3=+$GET(TOT(3))
+18 ;
+19 ; if 0 ECME transactions found, then no need to ask this next question
+20 IF TOT=0
SET VIEWTYPE="M"
GOTO VTPCB
+21 ;
+22 SET DIR(0)="S"
+23 IF TOT=1
SET DIR("A",1)=" There is 1 ECME transaction for this Rx/fill."
+24 IF '$TEST
SET DIR("A",1)=" There are "_TOT_" ECME transactions for this Rx/fill."
+25 SET DIR("A",2)=" "
+26 IF T2!T3
SET DIR("A",2)=" "_T1_" for the primary payer"_$SELECT(T2:", "_T2_" for the secondary payer",1:"")_$SELECT(T3:", "_T3_" for the tertiary payer",1:"")_"."
SET DIR("A",3)=" "
+27 SET MTXT="Most recent transaction"_$SELECT(T2!T3:" for each payer",1:"")
+28 SET ATXT="All transactions"
+29 SET DIR("A")="Select "_MTXT_" or "_ATXT
+30 SET DIR("B")="M"
+31 SET $PIECE(DIR(0),U,2)="M:"_MTXT_";A:"_ATXT
+32 WRITE !
DO ^DIR
KILL DIR
+33 IF Y=""!$DATA(DIRUT)
SET BPSVRXQ=1
GOTO VTPX
+34 SET VIEWTYPE=Y
+35 ;
VTPCB ;
+1 ; check for cancelled bills and ask how they should be handled
+2 KILL BPSVRXCLM
+3 ; build a list of all bills for Rx/fill# (IA #5355)
IF $$RXBILL^IBNCPUT3(RXIEN,FILL,"","",.BPSVRXIB)
+4 SET (IBIFN,IBC,IBA)=0
FOR
SET IBIFN=$ORDER(BPSVRXIB(IBIFN))
if 'IBIFN
QUIT
Begin DoDot:1
+5 SET IB=$GET(BPSVRXIB(IBIFN))
+6 ; cancelled bill
IF $PIECE(IB,U,8)=7!($PIECE(IB,U,2)="CB")!($PIECE(IB,U,2)="CN")
SET IBC=IBC+1
SET BPSVRXCLM(IBIFN)=0
QUIT
+7 ; non-cancelled bill
SET IBA=IBA+1
+8 SET BPSVRXCLM(IBIFN)=1
+9 QUIT
End DoDot:1
+10 SET BPSVRXCLM=IBA+IBC
+11 ;
+12 ; no cancelled bills found so no further questions
IF IBC=0
GOTO VTPX
+13 ;
+14 IF IBC
IF IBA
SET DIR("A",1)=" "_IBA_" non-cancelled bill"_$SELECT(IBA=1:"",1:"s")_" and "_IBC_" cancelled bill"_$SELECT(IBC=1:"",1:"s")_" exist for this Rx/fill."
+15 IF IBC
IF 'IBA
SET DIR("A",1)=" "_IBC_" cancelled bill"_$SELECT(IBC=1:"",1:"s")_", but no active bills exist for this Rx/fill."
+16 IF IBA
SET DIR("A",2)=" The non-cancelled bill"_$SELECT(IBA=1:"",1:"s")_" will automatically be included."
SET DIR("A",3)=" "
+17 IF 'IBA
SET DIR("A",2)=" "
+18 SET DIR("A")="Do you want to include the cancelled bill"_$SELECT(IBC=1:"",1:"s")
+19 SET DIR("B")="No"
+20 SET DIR(0)="Y"
+21 WRITE !
DO ^DIR
KILL DIR
+22 IF Y=""!$DATA(DIRUT)
SET BPSVRXQ=1
GOTO VTPX
+23 SET BPSVRXCAN=Y
+24 ;
+25 ; If the user wants cancelled bills, then no changes to the BPSVRXCLM list are needed so get out
+26 IF BPSVRXCAN
GOTO VTPX
+27 ;
+28 ; If the user does not want cancelled bills, then remove them from the BPSVRXCLM list
+29 SET IBIFN=0
FOR
SET IBIFN=$ORDER(BPSVRXCLM(IBIFN))
if 'IBIFN
QUIT
IF 'BPSVRXCLM(IBIFN)
KILL BPSVRXCLM(IBIFN)
+30 SET BPSVRXCLM=IBA
+31 ;
VTPX ;
+1 QUIT VIEWTYPE
+2 ;
BUILD(RXIEN,FILL,VIEWTYPE) ; build list
+1 ; This is called in the INIT section to build the ListMan scratch global
+2 ; all parameters are required and must exist when this is called
+3 ;
+4 ; special variable indicating this is the driver routine
SET BPSVRX=1
+5 IF '$DATA(ZTQUEUED)
WRITE !
+6 ; initialize display array
KILL ^TMP("BPSVRX",$JOB)
+7 ;
+8 ; View Prescriptions [PSO VIEW]
DO VIEWRX^BPSVRX1(RXIEN,FILL,VIEWTYPE,1)
+9 ; ECME Print Claim Log
DO LOG^BPSVRX1(RXIEN,FILL,VIEWTYPE,2)
+10 ; IB ECME Billing Events Report
DO BILL^BPSVRX1(RXIEN,FILL,VIEWTYPE,3)
+11 ; Comment out SD until US1401 is coded
+12 ; D SD^BPSVRX3(RXIEN,FILL,VIEWTYPE,4) ; SD Sensitive Drug
+13 ; ECME Claims-Response Inquiry Report
DO CRI^BPSVRX1(RXIEN,FILL,VIEWTYPE,5)
+14 ; View Pharmacy Insurance policies
DO INS^BPSVRX1(RXIEN,FILL,VIEWTYPE,6)
+15 ; List of TPJI-eligible bills
DO TPJILST^BPSVRX1(RXIEN,FILL,VIEWTYPE,7)
+16 ; MP Medication Profile
DO MP^BPSVRX3(RXIEN,FILL,VIEWTYPE,8)
+17 ; TPJI - Claim Information
DO TPJICI^BPSVRX1(RXIEN,FILL,VIEWTYPE,9)
+18 ; TPJI - AR Account Profile
DO TPJIARP^BPSVRX1(RXIEN,FILL,VIEWTYPE,10)
+19 ; TPJI - AR Comment History
DO TPJIARCH^BPSVRX1(RXIEN,FILL,VIEWTYPE,11)
+20 ; TPJI - ECME Rx Response Info
DO TPJIECME^BPSVRX1(RXIEN,FILL,VIEWTYPE,12)
+21 ; View Registration Elig Status
DO DGELST^BPSVRX2(RXIEN,FILL,VIEWTYPE,13)
+22 ; View Registration Elig Verification
DO DGELV^BPSVRX2(RXIEN,FILL,VIEWTYPE,14)
+23 ;
BUILDX ;
+1 QUIT
+2 ;
NAV(SNUM) ; ListMan nav jumping
+1 ; default to 1 if not defined
SET VALMBG=$GET(BPSVRX("LISTNAV",SNUM),1)
NAVX ;
+1 QUIT
+2 ;
UPDATE(DISP,HDR,TITLE,NAME,SNUM) ; update the BPSVRX ListMan display array
+1 ; DISP - display array to be merged into ^TMP("BPSVRX",$J)
+2 ; Assmues display lines are found in @DISP@(N,0)
+3 ; HDR - header data array (i.e. VALMHDR data); HDR(1)=line 1; HDR(2)=line 2; etc.
+4 ; TITLE - title of section (i.e. VALM("TITLE")
+5 ; NAME - name/description of section being added (required)
+6 ; SNUM - section number used for ListMan navigational jumps (required)
+7 ;
+8 NEW LN,Z,NODATA,BPSVID
+9 ;
+10 ; last line# used in display array
SET LN=+$ORDER(^TMP("BPSVRX",$JOB,""),-1)
+11 ;
+12 ; display name of section centered and reverse video
+13 IF $GET(NAME)'=""
Begin DoDot:1
+14 SET LN=LN+1
SET ^TMP("BPSVRX",$JOB,LN,0)=$$CJ^XLFSTR(NAME,80)
+15 ; reverse video line
DO CNTRL^VALM10(LN,1,80,IORVON,IORVOFF)
+16 ; store 1st line# of each section
IF '$DATA(BPSVRX("LISTNAV",SNUM))
SET BPSVRX("LISTNAV",SNUM)=LN
+17 QUIT
End DoDot:1
+18 ;
+19 ; merge in the ListMan title if one exists
+20 IF $GET(TITLE)'=""
Begin DoDot:1
+21 SET LN=LN+1
SET ^TMP("BPSVRX",$JOB,LN,0)=$$FLN(LN,TITLE)
+22 ; display a line under the title
DO CNTRL^VALM10(LN,1,80,IOUON,IOUOFF)
+23 QUIT
End DoDot:1
+24 ;
+25 ; merge in header data if this array exists
+26 IF $ORDER(HDR(0))
Begin DoDot:1
+27 SET Z=0
FOR
SET Z=$ORDER(HDR(Z))
if 'Z
QUIT
SET LN=LN+1
SET ^TMP("BPSVRX",$JOB,LN,0)=$$FLN(LN,$GET(HDR(Z)))
+28 ; display a line under the header data
DO CNTRL^VALM10(LN,1,80,IOUON,IOUOFF)
+29 QUIT
End DoDot:1
+30 ;
+31 ; merge in display array
+32 SET BPSVID="VALM VIDEO"
+33 IF DISP=""
SET DISP="NODATA"
+34 SET Z=0
FOR
SET Z=$ORDER(@DISP@(Z))
if 'Z
QUIT
SET LN=LN+1
SET ^TMP("BPSVRX",$JOB,LN,0)=$GET(@DISP@(Z,0))
Begin DoDot:1
+35 ; check for video attributes to be duplicated
+36 ; no video attributes on this line
IF '$DATA(^TMP(BPSVID,$JOB,999,Z))
QUIT
+37 ; copy video attributes
MERGE ^TMP(BPSVID,$JOB,VALMEVL,LN)=^TMP(BPSVID,$JOB,999,Z)
+38 ; clean-up
KILL ^TMP(BPSVID,$JOB,999,Z)
+39 QUIT
End DoDot:1
+40 ;
+41 ; display a message if no data found for this section
+42 IF '$ORDER(@DISP@(0))
Begin DoDot:1
+43 SET LN=LN+1
SET ^TMP("BPSVRX",$JOB,LN,0)=" "
+44 SET LN=LN+1
SET ^TMP("BPSVRX",$JOB,LN,0)=" <No data found for this section>"
+45 SET LN=LN+1
SET ^TMP("BPSVRX",$JOB,LN,0)=" "
+46 QUIT
End DoDot:1
+47 ;
+48 ; update the number of lines in the list
+49 SET VALMCNT=LN
+50 ;
UPDX ;
+1 QUIT
+2 ;
FLN(LINE,DATA) ; format line# LINE by reproducing any video attributes found in string DATA
+1 NEW VARON,VAROFF,FINDON,FINDOFF,COL,WIDTH
+2 ;
+3 ; on attribute
FOR VARON="IOBON","IORVON","IOUON","IOINHI"
Begin DoDot:1
+4 ; off attribute
SET VAROFF=$SELECT(VARON="IOBON":"IOBOFF",VARON="IORVON":"IORVOFF",VARON="IOUON":"IOUOFF",1:"IOINORM")
+5 FOR
SET FINDON=$FIND(DATA,@VARON)
if 'FINDON
QUIT
Begin DoDot:2
+6 ; starting column for video attribute
SET COL=FINDON-$LENGTH(@VARON)
+7 ; see if off attribute is also found
SET FINDOFF=$FIND(DATA,@VAROFF)
+8 ; width of affected text between on and off attributes
IF FINDOFF
SET WIDTH=FINDOFF-COL-$LENGTH(@VARON)-$LENGTH(@VAROFF)
+9 ; width of affected text (thru the end of the string)
IF 'FINDOFF
SET WIDTH=$LENGTH(DATA)-COL-$LENGTH(@VARON)
+10 ; save the video attribute using Listman API
DO CNTRL^VALM10(LINE,COL,WIDTH,@VARON,@VAROFF)
+11 ; remove 1st on attribute
SET DATA=$PIECE(DATA,@VARON,1)_$PIECE(DATA,@VARON,2,999)
+12 ; remove 1st off attribute
IF FINDOFF
SET DATA=$PIECE(DATA,@VAROFF,1)_$PIECE(DATA,@VAROFF,2,999)
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ; blank lines need to be non-nil so video attributes may exist for them
IF DATA=""
SET DATA=" "
FLNX ;
+1 QUIT DATA
+2 ;
HFS(SECTION,RTN,VRXHDR,HDRARY,BPSVRXKQ) ; output data to scratch host file and merge into ListMan display array
+1 ; SECTION - section code (e.g. "BER" - billing events report, "CRI" - claims-response inquiry)
+2 ; RTN - tag^routine to invoke to produce the report
+3 ; VRXHDR - name of section to appear at the start of the display
+4 ; HDRARY - header array
+5 ; BPSVRXKQ - section#
+6 ;
+7 NEW BPSHANDLE,BPSVDIR,BPSVFILE,HDR,POP,GLO,BPSARR,BVZ,BV1
+8 ;
+9 ; create a host file to write the data
+10 SET SECTION="BPSVRX_"_$GET(SECTION)
+11 SET BPSHANDLE=SECTION_"_"_$JOB
+12 SET BPSVDIR=$$DEFDIR^%ZISH()
+13 SET BPSVFILE=BPSHANDLE_".RPT"
+14 IF BPSVDIR=""
Begin DoDot:1
+15 SET HDR(1)="Error: Default directory is blank."
+16 SET HDR(2)="Please define one in the KERNEL SYSTEM PARAMETERS."
+17 DO UPDATE("",.HDR,"",VRXHDR,BPSVRXKQ)
+18 QUIT
End DoDot:1
GOTO HFSX
+19 ;
+20 DO OPEN^%ZISH(BPSHANDLE,BPSVDIR,BPSVFILE,"W")
+21 IF POP
Begin DoDot:1
+22 SET HDR(1)="Error: Unable to open scratch data file for writing."
+23 SET HDR(2)="Directory="_BPSVDIR
+24 SET HDR(3)="Filename="_BPSVFILE
+25 DO UPDATE("",.HDR,"",VRXHDR,BPSVRXKQ)
+26 QUIT
End DoDot:1
GOTO HFSX
+27 ;
+28 ; use the file
USE IO
+29 ; 80 char width and long screen
SET IOM=80
SET IOSL=100000
+30 ; create the report
DO @RTN
+31 ; close the data file
DO CLOSE^%ZISH(BPSHANDLE)
+32 ;
+33 ; move contents of scratch data file to scratch global
+34 SET GLO=$NAME(^TMP($JOB,SECTION,1,0))
+35 KILL ^TMP($JOB,SECTION)
+36 IF '$$FTG^%ZISH(BPSVDIR,BPSVFILE,GLO,3)
Begin DoDot:1
+37 SET HDR(1)="Error: Unable to read in the contents of the scratch data file."
+38 SET HDR(2)="Directory="_BPSVDIR
+39 SET HDR(3)="Filename="_BPSVFILE
+40 SET HDR(4)="Destination="_GLO
+41 DO UPDATE("",.HDR,"",VRXHDR,BPSVRXKQ)
+42 QUIT
End DoDot:1
GOTO HFSX
+43 ;
+44 ; delete the scratch data file
+45 SET BPSARR(BPSVFILE)=""
+46 IF $$DEL^%ZISH(BPSVDIR,$NAME(BPSARR))
+47 ;
+48 ; remove "PAGE 1" line from the beginning of the display data
+49 FOR BVZ=1:1:10
IF $$TRIM^XLFSTR($GET(^TMP($JOB,SECTION,BVZ,0)))="PAGE 1"
KILL ^TMP($JOB,SECTION,BVZ,0)
+50 ;
+51 ; remove all control characters and trailing spaces from all lines
+52 ; DBIAs #2735, #10104
SET BVZ=0
FOR
SET BVZ=$ORDER(^TMP($JOB,SECTION,BVZ))
if 'BVZ
QUIT
SET BV1=$GET(^TMP($JOB,SECTION,BVZ,0))
SET BV1=$$CTRL^XMXUTIL1(BV1)
SET BV1=$$TRIM^XLFSTR(BV1,"R")
SET ^TMP($JOB,SECTION,BVZ,0)=BV1
+53 ;
+54 ; update BPSVRX display array
+55 SET GLO=$NAME(^TMP($JOB,SECTION))
+56 DO UPDATE(GLO,.HDRARY,"",VRXHDR,BPSVRXKQ)
+57 ; clean up scratch global
KILL ^TMP($JOB,SECTION)
+58 ;
HFSX ;
+1 QUIT
+2 ;
RFL(RXIEN,FILLIST) ; Return a list of all ECME fill#s for the Rx
+1 NEW BP59,FL
+2 KILL FILLIST
+3 SET RXIEN=+$GET(RXIEN)
IF 'RXIEN
GOTO RFLX
+4 SET BP59=RXIEN
FOR
SET BP59=$ORDER(^BPST(BP59))
if $PIECE(BP59,".",1)'=RXIEN
QUIT
SET FL=$PIECE($GET(^BPST(BP59,1)),U,1)
IF FL'=""
SET FILLIST(FL)=BP59
RFLX ;
+1 QUIT
+2 ;
VER ; Selection from the ECME User Screen
+1 NEW BPSG,RXREF,BPSVRX
+2 DO FULL^VALM1
+3 WRITE !,"Enter the claim line number for the View ePharmacy Rx report."
+4 SET BPSG=$$ASKLINE^BPSSCRU4("Select item","C","Please select SINGLE Rx Line.")
+5 IF BPSG<1
GOTO VERX
+6 SET RXREF=$$RXREF^BPSSCRU2(+$PIECE(BPSG,U,4))
+7 SET BPSVRX("RXIEN")=$PIECE(RXREF,U,1)
+8 SET BPSVRX("FILL#")=$PIECE(RXREF,U,2)
+9 DO ^BPSVRX
VERX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
