- 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 Jan 18, 2025@02:54:51 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 ;