Summary Table

Categories Total Count
PII 0
URL 0
DNS 0
EKL 0
IP 0
PORT 0
VsID 0
CF 0
AI 0
VPD 0
PL 0
Other 0

File Content

KIDS Distribution saved on Mar 19, 2019@12:20:43
MCCF EDI TAS EPHARMACY BUILD 10
**KIDS**:PSO IB BUNDLE 10.0^PSO*7.0*528^IB*2.0*624^

**INSTALL NAME**
PSO IB BUNDLE 10.0
"BLD",11109,0)
PSO IB BUNDLE 10.0^^1^3190319^y
"BLD",11109,6.3)
8
"BLD",11109,10,0)
^9.63^2^2
"BLD",11109,10,2,0)
PSO*7.0*528^1
"BLD",11109,10,3,0)
IB*2.0*624^1
"BLD",11109,10,"B","IB*2.0*624",3)

"BLD",11109,10,"B","PSO*7.0*528",2)

"BLD",11109,"KRN",0)
^9.67PA^779.2^20
"BLD",11109,"KRN",.4,0)
.4
"BLD",11109,"KRN",.401,0)
.401
"BLD",11109,"KRN",.402,0)
.402
"BLD",11109,"KRN",.403,0)
.403
"BLD",11109,"KRN",.5,0)
.5
"BLD",11109,"KRN",.84,0)
.84
"BLD",11109,"KRN",3.6,0)
3.6
"BLD",11109,"KRN",3.8,0)
3.8
"BLD",11109,"KRN",9.2,0)
9.2
"BLD",11109,"KRN",9.8,0)
9.8
"BLD",11109,"KRN",19,0)
19
"BLD",11109,"KRN",19.1,0)
19.1
"BLD",11109,"KRN",101,0)
101
"BLD",11109,"KRN",409.61,0)
409.61
"BLD",11109,"KRN",771,0)
771
"BLD",11109,"KRN",779.2,0)
779.2
"BLD",11109,"KRN",870,0)
870
"BLD",11109,"KRN",8989.51,0)
8989.51
"BLD",11109,"KRN",8989.52,0)
8989.52
"BLD",11109,"KRN",8994,0)
8994
"BLD",11109,"KRN","B",.4,.4)

"BLD",11109,"KRN","B",.401,.401)

"BLD",11109,"KRN","B",.402,.402)

"BLD",11109,"KRN","B",.403,.403)

"BLD",11109,"KRN","B",.5,.5)

"BLD",11109,"KRN","B",.84,.84)

"BLD",11109,"KRN","B",3.6,3.6)

"BLD",11109,"KRN","B",3.8,3.8)

"BLD",11109,"KRN","B",9.2,9.2)

"BLD",11109,"KRN","B",9.8,9.8)

"BLD",11109,"KRN","B",19,19)

"BLD",11109,"KRN","B",19.1,19.1)

"BLD",11109,"KRN","B",101,101)

"BLD",11109,"KRN","B",409.61,409.61)

"BLD",11109,"KRN","B",771,771)

"BLD",11109,"KRN","B",779.2,779.2)

"BLD",11109,"KRN","B",870,870)

"BLD",11109,"KRN","B",8989.51,8989.51)

"BLD",11109,"KRN","B",8989.52,8989.52)

"BLD",11109,"KRN","B",8994,8994)

"MBREQ")
0
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"VER")
8.0^22.2
**INSTALL NAME**
PSO*7.0*528
"BLD",11107,0)
PSO*7.0*528^OUTPATIENT PHARMACY^0^3190319^y
"BLD",11107,4,0)
^9.64PA^^
"BLD",11107,6.3)
8
"BLD",11107,"KRN",0)
^9.67PA^779.2^20
"BLD",11107,"KRN",.4,0)
.4
"BLD",11107,"KRN",.401,0)
.401
"BLD",11107,"KRN",.402,0)
.402
"BLD",11107,"KRN",.403,0)
.403
"BLD",11107,"KRN",.5,0)
.5
"BLD",11107,"KRN",.84,0)
.84
"BLD",11107,"KRN",3.6,0)
3.6
"BLD",11107,"KRN",3.8,0)
3.8
"BLD",11107,"KRN",9.2,0)
9.2
"BLD",11107,"KRN",9.8,0)
9.8
"BLD",11107,"KRN",9.8,"NM",0)
^9.68A^11^11
"BLD",11107,"KRN",9.8,"NM",1,0)
PSOBORP0^^0^B13070904
"BLD",11107,"KRN",9.8,"NM",2,0)
PSOBORP1^^0^B122430244
"BLD",11107,"KRN",9.8,"NM",3,0)
PSOBORP2^^0^B24488979
"BLD",11107,"KRN",9.8,"NM",4,0)
PSOBORP3^^0^B198511557
"BLD",11107,"KRN",9.8,"NM",5,0)
PSOREJP2^^0^B228344655
"BLD",11107,"KRN",9.8,"NM",6,0)
PSOREJP3^^0^B276853501
"BLD",11107,"KRN",9.8,"NM",7,0)
PSOREJP5^^0^B58255274
"BLD",11107,"KRN",9.8,"NM",8,0)
PSOREJU3^^0^B153391658
"BLD",11107,"KRN",9.8,"NM",9,0)
PSOREJUT^^0^B114631275
"BLD",11107,"KRN",9.8,"NM",10,0)
PSOTRI^^0^B32068290
"BLD",11107,"KRN",9.8,"NM",11,0)
PSORXPA1^^0^B38381777
"BLD",11107,"KRN",9.8,"NM","B","PSOBORP0",1)

"BLD",11107,"KRN",9.8,"NM","B","PSOBORP1",2)

"BLD",11107,"KRN",9.8,"NM","B","PSOBORP2",3)

"BLD",11107,"KRN",9.8,"NM","B","PSOBORP3",4)

"BLD",11107,"KRN",9.8,"NM","B","PSOREJP2",5)

"BLD",11107,"KRN",9.8,"NM","B","PSOREJP3",6)

"BLD",11107,"KRN",9.8,"NM","B","PSOREJP5",7)

"BLD",11107,"KRN",9.8,"NM","B","PSOREJU3",8)

"BLD",11107,"KRN",9.8,"NM","B","PSOREJUT",9)

"BLD",11107,"KRN",9.8,"NM","B","PSORXPA1",11)

"BLD",11107,"KRN",9.8,"NM","B","PSOTRI",10)

"BLD",11107,"KRN",19,0)
19
"BLD",11107,"KRN",19,"NM",0)
^9.68A^1^1
"BLD",11107,"KRN",19,"NM",1,0)
PSO TRI CVA OVERRIDE REPORT^^0
"BLD",11107,"KRN",19,"NM","B","PSO TRI CVA OVERRIDE REPORT",1)

"BLD",11107,"KRN",19.1,0)
19.1
"BLD",11107,"KRN",101,0)
101
"BLD",11107,"KRN",409.61,0)
409.61
"BLD",11107,"KRN",771,0)
771
"BLD",11107,"KRN",779.2,0)
779.2
"BLD",11107,"KRN",870,0)
870
"BLD",11107,"KRN",8989.51,0)
8989.51
"BLD",11107,"KRN",8989.52,0)
8989.52
"BLD",11107,"KRN",8994,0)
8994
"BLD",11107,"KRN","B",.4,.4)

"BLD",11107,"KRN","B",.401,.401)

"BLD",11107,"KRN","B",.402,.402)

"BLD",11107,"KRN","B",.403,.403)

"BLD",11107,"KRN","B",.5,.5)

"BLD",11107,"KRN","B",.84,.84)

"BLD",11107,"KRN","B",3.6,3.6)

"BLD",11107,"KRN","B",3.8,3.8)

"BLD",11107,"KRN","B",9.2,9.2)

"BLD",11107,"KRN","B",9.8,9.8)

"BLD",11107,"KRN","B",19,19)

"BLD",11107,"KRN","B",19.1,19.1)

"BLD",11107,"KRN","B",101,101)

"BLD",11107,"KRN","B",409.61,409.61)

"BLD",11107,"KRN","B",771,771)

"BLD",11107,"KRN","B",779.2,779.2)

"BLD",11107,"KRN","B",870,870)

"BLD",11107,"KRN","B",8989.51,8989.51)

"BLD",11107,"KRN","B",8989.52,8989.52)

"BLD",11107,"KRN","B",8994,8994)

"BLD",11107,"QUES",0)
^9.62^^
"KRN",19,2921330,-1)
0^1
"KRN",19,2921330,0)
PSO TRI CVA OVERRIDE REPORT^TRICARE CHAMPVA Override Report^^R^^PSO TRICARE/CHAMPVA MGR^^^^^^OUTPATIENT PHARMACY
"KRN",19,2921330,1,0)
^19.06^1^1^3190104^^
"KRN",19,2921330,1,1,0)
This option will allow a user to create a TRICARE CHAMPVA Override report.
"KRN",19,2921330,25)
EN^PSOBORP0(1)
"KRN",19,2921330,99)
61915,74360
"KRN",19,2921330,"U")
TRICARE CHAMPVA OVERRIDE REPOR
"MBREQ")
1
"ORD",18,19)
19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
"ORD",18,19,0)
OPTION
"PKG",170,-1)
1^1
"PKG",170,0)
OUTPATIENT PHARMACY^PSO^OUTPATIENT LABELS, PROFILE, INVENTORY, PRESCRIPTIONS
"PKG",170,22,0)
^9.49I^1^1
"PKG",170,22,1,0)
7.0^2971216^2981113^1
"PKG",170,22,1,"PAH",1,0)
528^3190319
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
11
"RTN","PSOBORP0")
0^1^B13070904
"RTN","PSOBORP0",1,0)
PSOBORP0 ;ALBANY/BLD - TRICARE-CHAMPVA BYPASS/OVERRIDE AUDIT REPORT ; 10/15/12 4:26pm
"RTN","PSOBORP0",2,0)
;;7.0;OUTPATIENT PHARMACY;**358,385,415,528**;DEC 1997;Build 8
"RTN","PSOBORP0",3,0)
;
"RTN","PSOBORP0",4,0)
;***********copied from routine BPSRPT0************
"RTN","PSOBORP0",5,0)
;
"RTN","PSOBORP0",6,0)
Q
"RTN","PSOBORP0",7,0)
;
"RTN","PSOBORP0",8,0)
; Front End for ECME Reports
"RTN","PSOBORP0",9,0)
;
"RTN","PSOBORP0",10,0)
;
"RTN","PSOBORP0",11,0)
;The following local variables and arrays are passed around the PSOBORP* routines
"RTN","PSOBORP0",12,0)
;and are not passed as parameters but are assumed to be defined:
"RTN","PSOBORP0",13,0)
; variables - PSOATYP,PSOBEGDT,PSOENDDT,PSONOW,PSOPHARM,PSOPHMST,PSOPROV,PSOREJCD,
"RTN","PSOBORP0",14,0)
; PSORPTNM,PSOQ,PSORTYPE,PSOSCR,PSOTOTAL
"RTN","PSOBORP0",15,0)
; arrays - PSOEXCEL,PSOSEL / PSOAUD is passed between PSOBORP2 and PSOBORP3
"RTN","PSOBORP0",16,0)
;
"RTN","PSOBORP0",17,0)
EN(PSORTYPE) ;
"RTN","PSOBORP0",18,0)
N %,ACTDT,AMT,BPQ,CODE,IO,PSOACREJ,PSOATYP,PSOAUTREV,PSOBEGDT,PSOCCRSN,PSODRGCL,PSODRUG,PSOENDDT,PSOEXCEL,PSONOW
"RTN","PSOBORP0",19,0)
N PSOPHARM,PSOINSINF,PSOMWC,PSOQ,PSOUT,PSOPROV,PSOQSTDRG,PSOREJCD,PSORLNRL,PSORPTNAM,PSORTBCK
"RTN","PSOBORP0",20,0)
N PSOSEL,PSOSCR,PSOSMDET,PSOSEL,PSOTOTAL,POS,PSOINS,PSOARR,PSOELIG,PSOOPCL,PSOPHMST,PSORPTNM,STAT,X,Y
"RTN","PSOBORP0",21,0)
;
"RTN","PSOBORP0",22,0)
K PSOSEL
"RTN","PSOBORP0",23,0)
;
"RTN","PSOBORP0",24,0)
S PSORPTNM="TRICARE-CHAMPVA OVERRIDE REPORT"
"RTN","PSOBORP0",25,0)
;
"RTN","PSOBORP0",26,0)
;Verify that a valid report has been requested
"RTN","PSOBORP0",27,0)
I PSORTYPE'=1 W "<Invalid Menu Definition - Report Undefined>" H 3 Q
"RTN","PSOBORP0",28,0)
;
"RTN","PSOBORP0",29,0)
;Get current Date/Time
"RTN","PSOBORP0",30,0)
S PSONOW=$$FMTE^XLFDT($$NOW^XLFDT)
"RTN","PSOBORP0",31,0)
;
"RTN","PSOBORP0",32,0)
;Prompt for ECME Pharmacy Division(s) (No Default)
"RTN","PSOBORP0",33,0)
;Sets up PSOPHARM variable and array, PSOPHARM="A" ALL or PSOPHARM="D",PSOPHARM(ptr) for list
"RTN","PSOBORP0",34,0)
S X=$$SELPHARM^PSOBORP1(.PSOSEL) I X="^" Q
"RTN","PSOBORP0",35,0)
;
"RTN","PSOBORP0",36,0)
;Prompt to Display TRICARE or CHAMPVA or ALL entries (Default to ALL)
"RTN","PSOBORP0",37,0)
;Returns T for TRICARE, C for CHAMPVA, A for ALL
"RTN","PSOBORP0",38,0)
S PSOATYP=$$SELATYP^PSOBORP1("A")
"RTN","PSOBORP0",39,0)
I PSOATYP="^" Q
"RTN","PSOBORP0",40,0)
;
"RTN","PSOBORP0",41,0)
;Prompt to Display Summary or Detail Format (Default to Detail)
"RTN","PSOBORP0",42,0)
;Returns "S" for Summary, "D" for Detail
"RTN","PSOBORP0",43,0)
S PSOSMDET=$$SELSMDET^PSOBORP1(2) I PSOSMDET="^" Q
"RTN","PSOBORP0",44,0)
S PSOSEL("SUM_DETAIL")=PSOSMDET
"RTN","PSOBORP0",45,0)
;
"RTN","PSOBORP0",46,0)
;Prompt to select Date Range
"RTN","PSOBORP0",47,0)
;Returns (Start Date^End Date)
"RTN","PSOBORP0",48,0)
S PSOBEGDT=$$SELDATE^PSOBORP1("TRANSACTION") D I PSOBEGDT="^" Q
"RTN","PSOBORP0",49,0)
.I PSOBEGDT="^" Q
"RTN","PSOBORP0",50,0)
.S PSOENDDT=$P(PSOBEGDT,U,2)
"RTN","PSOBORP0",51,0)
.S PSOBEGDT=$P(PSOBEGDT,U)
"RTN","PSOBORP0",52,0)
S PSOSEL("BEGIN DATE")=PSOBEGDT
"RTN","PSOBORP0",53,0)
S PSOSEL("END DATE")=PSOENDDT
"RTN","PSOBORP0",54,0)
;
"RTN","PSOBORP0",55,0)
;Prompt to Include (S)pecific TC Code or (A)LL (Default to ALL)
"RTN","PSOBORP0",56,0)
S PSOREJCD=$$SELTCCD^PSOBORP1(.PSOSEL)
"RTN","PSOBORP0",57,0)
I PSOREJCD="^" Q
"RTN","PSOBORP0",58,0)
;
"RTN","PSOBORP0",59,0)
;Prompt to select One of the following: Specific Pharmacist or ALL Pharmacist
"RTN","PSOBORP0",60,0)
S PSOPHMST=$$SELPHMST^PSOBORP1(.PSOSEL)
"RTN","PSOBORP0",61,0)
I PSOPHMST="^" Q
"RTN","PSOBORP0",62,0)
;
"RTN","PSOBORP0",63,0)
;Prompt to select one of the following: Specific Provider or ALL Providers
"RTN","PSOBORP0",64,0)
S PSOPROV=$$SELPROV^PSOBORP1(.PSOSEL)
"RTN","PSOBORP0",65,0)
I PSOPROV="^" Q
"RTN","PSOBORP0",66,0)
;
"RTN","PSOBORP0",67,0)
;Prompt to Include Group/Subtotal Report by (R) Pharmacy or (P)rovider/Prescriber Name
"RTN","PSOBORP0",68,0)
;Returns ()
"RTN","PSOBORP0",69,0)
S PSOTOTAL=$$PSOTOTAL^PSOBORP1()
"RTN","PSOBORP0",70,0)
I PSOTOTAL="^" Q
"RTN","PSOBORP0",71,0)
S PSOSEL("TOTALS BY")=PSOTOTAL
"RTN","PSOBORP0",72,0)
;
"RTN","PSOBORP0",73,0)
;Prompt for Excel Capture (Detail Only)
"RTN","PSOBORP0",74,0)
S PSOEXCEL=0 I PSOSEL("SUM_DETAIL")="D" D I PSOEXCEL="^" Q
"RTN","PSOBORP0",75,0)
.S PSOEXCEL=$$SELEXCEL^PSOBORP1() I PSOEXCEL="^" Q
"RTN","PSOBORP0",76,0)
.S PSOSEL("EXCEL")=PSOEXCEL
"RTN","PSOBORP0",77,0)
;
"RTN","PSOBORP0",78,0)
;Prompt for the Device
"RTN","PSOBORP0",79,0)
I 'PSOEXCEL D
"RTN","PSOBORP0",80,0)
.W !!,"WARNING - THIS REPORT REQUIRES THAT A DEVICE WITH 132 COLUMN WIDTH BE USED."
"RTN","PSOBORP0",81,0)
.W !,"IT WILL NOT DISPLAY CORRECTLY USING 80 COLUMN WIDTH DEVICES",!
"RTN","PSOBORP0",82,0)
N PSOSCR S PSOSCR=0
"RTN","PSOBORP0",83,0)
S PSOQ=0 D DEVICE(PSORPTNM) I PSOQ D ^%ZISC QUIT
"RTN","PSOBORP0",84,0)
;
"RTN","PSOBORP0",85,0)
;Compile and Run the Report
"RTN","PSOBORP0",86,0)
D RUN(.PSOSEL)
"RTN","PSOBORP0",87,0)
I '$G(PSOUT) D PAUSE^PSOBORP1
"RTN","PSOBORP0",88,0)
;
"RTN","PSOBORP0",89,0)
Q
"RTN","PSOBORP0",90,0)
;
"RTN","PSOBORP0",91,0)
;Compile and Run the Report
"RTN","PSOBORP0",92,0)
;
"RTN","PSOBORP0",93,0)
RUN(PSOEXCEL,PSORPTNAM,PSOSMDET) ;
"RTN","PSOBORP0",94,0)
N PSOPAGE,PSOTMP
"RTN","PSOBORP0",95,0)
;
"RTN","PSOBORP0",96,0)
D RUNRPT^PSOBORP2(.PSOSEL)
"RTN","PSOBORP0",97,0)
D ^%ZISC
"RTN","PSOBORP0",98,0)
Q
"RTN","PSOBORP0",99,0)
;
"RTN","PSOBORP0",100,0)
;Prompt For the Device
"RTN","PSOBORP0",101,0)
;
"RTN","PSOBORP0",102,0)
; Returns Device variables and PSOSCR
"RTN","PSOBORP0",103,0)
;
"RTN","PSOBORP0",104,0)
DEVICE(PSORPTNAM) N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
"RTN","PSOBORP0",105,0)
S %ZIS="QM"
"RTN","PSOBORP0",106,0)
D ^%ZIS
"RTN","PSOBORP0",107,0)
I POP S PSOQ=1
"RTN","PSOBORP0",108,0)
;
"RTN","PSOBORP0",109,0)
;Check for exit
"RTN","PSOBORP0",110,0)
I $G(PSOQ) G XDEV
"RTN","PSOBORP0",111,0)
I IO=IO(0) S PSOSCR=1 ;User wants to print to the screen
"RTN","PSOBORP0",112,0)
;
"RTN","PSOBORP0",113,0)
S PSOSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
"RTN","PSOBORP0",114,0)
I $D(IO("Q")) D S PSOQ=1
"RTN","PSOBORP0",115,0)
. S ZTRTN="RUN^PSOBORP0(PSOEXCEL,PSORPTNAM,PSOSMDET)"
"RTN","PSOBORP0",116,0)
. S ZTIO=ION
"RTN","PSOBORP0",117,0)
. S ZTSAVE("*")=""
"RTN","PSOBORP0",118,0)
. S ZTDESC="PSO REPORT: "_PSORPTNM
"RTN","PSOBORP0",119,0)
. D ^%ZTLOAD
"RTN","PSOBORP0",120,0)
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
"RTN","PSOBORP0",121,0)
. D HOME^%ZIS
"RTN","PSOBORP0",122,0)
U IO
"RTN","PSOBORP0",123,0)
XDEV ;
"RTN","PSOBORP0",124,0)
Q
"RTN","PSOBORP1")
0^2^B122430244
"RTN","PSOBORP1",1,0)
PSOBORP1 ;ALBANY/BLD - TRICARE-CHAMPVA BYPASS/OVERRIDE AUDIT REPORT (CONT) ;10/17/12 3:38pm
"RTN","PSOBORP1",2,0)
;;7.0;OUTPATIENT PHARMACY;**358,385,415,427,528**;DEC 1997;Build 8
"RTN","PSOBORP1",3,0)
;
"RTN","PSOBORP1",4,0)
;***********copied from routine BPSRPT3 AND BPSRPT4************
"RTN","PSOBORP1",5,0)
;
"RTN","PSOBORP1",6,0)
Q
"RTN","PSOBORP1",7,0)
;
"RTN","PSOBORP1",8,0)
;
"RTN","PSOBORP1",9,0)
;
"RTN","PSOBORP1",10,0)
SELPHARM(PSOSEL) N DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y
"RTN","PSOBORP1",11,0)
;
"RTN","PSOBORP1",12,0)
; Select the ECME Pharmacy or Pharmacies
"RTN","PSOBORP1",13,0)
;
"RTN","PSOBORP1",14,0)
; Input Variable -> none
"RTN","PSOBORP1",15,0)
; Return Value -> "" = Valid Entry or Entries Selected
"RTN","PSOBORP1",16,0)
; ^ = Exit
"RTN","PSOBORP1",17,0)
;
"RTN","PSOBORP1",18,0)
; Output Variable -> PSOPHARM = "D" One or More Pharmacies Selected
"RTN","PSOBORP1",19,0)
; = "A" User Entered 'ALL'
"RTN","PSOBORP1",20,0)
;
"RTN","PSOBORP1",21,0)
; If PSOPHARM = 1 then the PSOPHARM array will be defined where:
"RTN","PSOBORP1",22,0)
; PSOPHARM(ptr) = ptr ^ BPS PHARMACY NAME and
"RTN","PSOBORP1",23,0)
; ptr = Internal Pointer to OUTPATIENT SITE file (#59)
"RTN","PSOBORP1",24,0)
;
"RTN","PSOBORP1",25,0)
;Reset PSOPHARM array
"RTN","PSOBORP1",26,0)
K PSOPHARM
"RTN","PSOBORP1",27,0)
;
"RTN","PSOBORP1",28,0)
;First see if they want to enter individual divisions or ALL
"RTN","PSOBORP1",29,0)
S DIR(0)="S^D:DIVISION;A:ALL"
"RTN","PSOBORP1",30,0)
S DIR("A")="Select Certain Pharmacy (D)ivisions or (A)LL"
"RTN","PSOBORP1",31,0)
S DIR("L",1)="Select one of the following:"
"RTN","PSOBORP1",32,0)
S DIR("L",2)=""
"RTN","PSOBORP1",33,0)
S DIR("L",3)=" D DIVISION"
"RTN","PSOBORP1",34,0)
S DIR("L",4)=" A ALL"
"RTN","PSOBORP1",35,0)
D ^DIR K DIR
"RTN","PSOBORP1",36,0)
;
"RTN","PSOBORP1",37,0)
;Check for "^" or timeout, otherwise define PSOPHARM
"RTN","PSOBORP1",38,0)
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
"RTN","PSOBORP1",39,0)
E S (PSOSEL("DIVISION"),PSOPHARM)=Y
"RTN","PSOBORP1",40,0)
;If division selected, ask prompt
"RTN","PSOBORP1",41,0)
I $G(PSOPHARM)="D" F D Q:Y="^"!(Y="")
"RTN","PSOBORP1",42,0)
.;
"RTN","PSOBORP1",43,0)
.;Prompt for entry
"RTN","PSOBORP1",44,0)
.K X S DIC(0)="QEAM",DIC=59,DIC("A")="Select ECME Pharmacy Division(s): "
"RTN","PSOBORP1",45,0)
.W ! D ^DIC
"RTN","PSOBORP1",46,0)
.;
"RTN","PSOBORP1",47,0)
.;Check for "^" or timeout
"RTN","PSOBORP1",48,0)
.I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPHARM S Y="^" Q
"RTN","PSOBORP1",49,0)
.;
"RTN","PSOBORP1",50,0)
.;Check for blank entry, quit if no previous selections
"RTN","PSOBORP1",51,0)
.I $G(X)="" S Y=$S($D(PSOPHARM)>9:"",1:"^") K:Y="^" PSOPHARM Q
"RTN","PSOBORP1",52,0)
.;
"RTN","PSOBORP1",53,0)
.;Handle Deletes
"RTN","PSOBORP1",54,0)
.I $D(PSOPHARM(+Y)) D Q:Y="^" I 1
"RTN","PSOBORP1",55,0)
..N P
"RTN","PSOBORP1",56,0)
..S P=Y ;Save Original Value
"RTN","PSOBORP1",57,0)
..S DIR(0)="S^Y:YES;N:NO",DIR("A")="Delete "_$P(P,U,2)_" from your list?"
"RTN","PSOBORP1",58,0)
..S DIR("B")="NO" D ^DIR
"RTN","PSOBORP1",59,0)
..I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPHARM S Y="^" Q
"RTN","PSOBORP1",60,0)
..I Y="Y" K PSOPHARM(+P),PSOPHARM("B",$P(P,U,2),+P)
"RTN","PSOBORP1",61,0)
..S Y=P ;Restore Original Value
"RTN","PSOBORP1",62,0)
..K P
"RTN","PSOBORP1",63,0)
.E D
"RTN","PSOBORP1",64,0)
..;Define new entries in PSOPHARM array
"RTN","PSOBORP1",65,0)
..S PSOPHARM(+Y)=Y
"RTN","PSOBORP1",66,0)
..S PSOPHARM("B",$P(Y,U,2),+Y)=""
"RTN","PSOBORP1",67,0)
.;
"RTN","PSOBORP1",68,0)
.;Display a list of selected divisions
"RTN","PSOBORP1",69,0)
.I $D(PSOPHARM)>9 D
"RTN","PSOBORP1",70,0)
..N X
"RTN","PSOBORP1",71,0)
..W !,?2,"Selected:"
"RTN","PSOBORP1",72,0)
..S X="" F S X=$O(PSOPHARM("B",X)) Q:X="" W !,?10,X
"RTN","PSOBORP1",73,0)
..K X
"RTN","PSOBORP1",74,0)
.Q
"RTN","PSOBORP1",75,0)
;
"RTN","PSOBORP1",76,0)
K PSOPHARM("B")
"RTN","PSOBORP1",77,0)
M PSOSEL("DIVISION")=PSOPHARM
"RTN","PSOBORP1",78,0)
Q Y
"RTN","PSOBORP1",79,0)
;
"RTN","PSOBORP1",80,0)
;
"RTN","PSOBORP1",81,0)
SELSMDET(DFLT) ;
"RTN","PSOBORP1",82,0)
;
"RTN","PSOBORP1",83,0)
; Display (S)ummary or (D)etail Format
"RTN","PSOBORP1",84,0)
;
"RTN","PSOBORP1",85,0)
; Input Variable -> DFLT = 1 Summary
"RTN","PSOBORP1",86,0)
; 2 Detail
"RTN","PSOBORP1",87,0)
;
"RTN","PSOBORP1",88,0)
; Return Value -> "S" = Summary
"RTN","PSOBORP1",89,0)
; "D" = Detail
"RTN","PSOBORP1",90,0)
; ^ = Exit
"RTN","PSOBORP1",91,0)
;
"RTN","PSOBORP1",92,0)
N DIR,DIRUT,DTOUT,DUOUT,X,Y
"RTN","PSOBORP1",93,0)
;
"RTN","PSOBORP1",94,0)
S DFLT=$S($G(DFLT)=1:"Summary",$G(DFLT)=2:"Detail",1:"Detail")
"RTN","PSOBORP1",95,0)
S DIR(0)="S^S:Summary;D:Detail",DIR("A")="Display (S)ummary or (D)etail Format",DIR("B")=DFLT
"RTN","PSOBORP1",96,0)
D ^DIR
"RTN","PSOBORP1",97,0)
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
"RTN","PSOBORP1",98,0)
Q Y
"RTN","PSOBORP1",99,0)
;
"RTN","PSOBORP1",100,0)
;
"RTN","PSOBORP1",101,0)
SELDATE(TYPE) ;select begin date
"RTN","PSOBORP1",102,0)
; Enter Date Range
"RTN","PSOBORP1",103,0)
;
"RTN","PSOBORP1",104,0)
; Input Variable -> TYPE = TRANSACTION
"RTN","PSOBORP1",105,0)
;
"RTN","PSOBORP1",106,0)
;
"RTN","PSOBORP1",107,0)
; Return Value -> P1^P2
"RTN","PSOBORP1",108,0)
;
"RTN","PSOBORP1",109,0)
; where P1 = From Date
"RTN","PSOBORP1",110,0)
; = ^ Exit
"RTN","PSOBORP1",111,0)
; P2 = To Date
"RTN","PSOBORP1",112,0)
; = blank for Exit
"RTN","PSOBORP1",113,0)
N PSOSIBDT,DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y
"RTN","PSOBORP1",114,0)
;
"RTN","PSOBORP1",115,0)
SELDATE1 ;
"RTN","PSOBORP1",116,0)
N VAL
"RTN","PSOBORP1",117,0)
S VAL="",DIR(0)="DA^:DT:EX",DIR("A")="START WITH "_TYPE_" DATE: ",DIR("B")="T-1"
"RTN","PSOBORP1",118,0)
W ! D ^DIR
"RTN","PSOBORP1",119,0)
;
"RTN","PSOBORP1",120,0)
;Check for "^", timeout, or blank entry
"RTN","PSOBORP1",121,0)
I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^"
"RTN","PSOBORP1",122,0)
;
"RTN","PSOBORP1",123,0)
I VAL="" D
"RTN","PSOBORP1",124,0)
.S $P(VAL,U)=Y
"RTN","PSOBORP1",125,0)
.S DIR(0)="DA^"_VAL_":DT:EX",DIR("A")=" GO TO "_TYPE_" DATE: ",DIR("B")="T"
"RTN","PSOBORP1",126,0)
.D ^DIR
"RTN","PSOBORP1",127,0)
.;
"RTN","PSOBORP1",128,0)
.;Check for "^", timeout, or blank entry
"RTN","PSOBORP1",129,0)
.I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^" Q
"RTN","PSOBORP1",130,0)
.;
"RTN","PSOBORP1",131,0)
.;Define Entry
"RTN","PSOBORP1",132,0)
.S $P(VAL,U,2)=Y
"RTN","PSOBORP1",133,0)
;
"RTN","PSOBORP1",134,0)
Q VAL
"RTN","PSOBORP1",135,0)
;
"RTN","PSOBORP1",136,0)
SELATYP(DFLT) ;
"RTN","PSOBORP1",137,0)
;
"RTN","PSOBORP1",138,0)
; Display (T)RICARE or (C)HAMPVA OR (A)LL Format
"RTN","PSOBORP1",139,0)
;
"RTN","PSOBORP1",140,0)
; Input Variable -> DFLT = A ALL
"RTN","PSOBORP1",141,0)
; T TRICARE
"RTN","PSOBORP1",142,0)
; C CHAMPVA
"RTN","PSOBORP1",143,0)
;
"RTN","PSOBORP1",144,0)
; Return Value -> A = ALL
"RTN","PSOBORP1",145,0)
; T = TRICARE
"RTN","PSOBORP1",146,0)
; C = CHAMPVA
"RTN","PSOBORP1",147,0)
; ^ = Exit
"RTN","PSOBORP1",148,0)
;
"RTN","PSOBORP1",149,0)
N DIR,DIRUT,DTOUT,DUOUT,EXIT,X,Y
"RTN","PSOBORP1",150,0)
S EXIT=0
"RTN","PSOBORP1",151,0)
S DFLT=$S($G(DFLT)="T":"TRICARE",$G(DFLT)="C":"CHAMPVA",1:"ALL")
"RTN","PSOBORP1",152,0)
S DIR(0)="SO^T:TRICARE;C:CHAMPVA;A:ALL",DIR("A")="Display (T)RICARE or (C)HAMPVA or (A)LL Entries",DIR("B")=DFLT
"RTN","PSOBORP1",153,0)
D ^DIR
"RTN","PSOBORP1",154,0)
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
"RTN","PSOBORP1",155,0)
I Y="A" K PSOSEL("ELIG_TYPE") D
"RTN","PSOBORP1",156,0)
.S PSOSEL("ELIG_TYPE")="A"
"RTN","PSOBORP1",157,0)
.S PSOSEL("ELIG_TYPE","T")="TRICARE"
"RTN","PSOBORP1",158,0)
.S PSOSEL("ELIG_TYPE","C")="CHAMPVA"
"RTN","PSOBORP1",159,0)
.S EXIT=1
"RTN","PSOBORP1",160,0)
I EXIT Q Y
"RTN","PSOBORP1",161,0)
I Y'="" S PSOSEL("ELIG_TYPE")=Y,PSOSEL("ELIG_TYPE",Y)=$S(Y="T":"TRICARE",Y="C":"CHAMPVA",1:"ALL")
"RTN","PSOBORP1",162,0)
Q Y
"RTN","PSOBORP1",163,0)
;
"RTN","PSOBORP1",164,0)
SELTCCD(PSOSEL) ;
"RTN","PSOBORP1",165,0)
;
"RTN","PSOBORP1",166,0)
;Prompt to Include (I)npatient,(N)on-Billable, (R)eject, (P)artial, or A)ll: (no default)
"RTN","PSOBORP1",167,0)
;
"RTN","PSOBORP1",168,0)
N DIC,DIR,DIRUT,DUOUT,EXIT,REJ,X,Y,I
"RTN","PSOBORP1",169,0)
S EXIT=0
"RTN","PSOBORP1",170,0)
F I=1:1:2 D Q:Y="A"!(EXIT)
"RTN","PSOBORP1",171,0)
.S DIR(0)="SO^I:INPATIENT;N:NON-BILLABLE;R:REJECT OVERRIDE;P:PARTIAL FILL;A:ALL"
"RTN","PSOBORP1",172,0)
.S DIR("A")="Select one of the following: **Can select multiples - limit of 2** "
"RTN","PSOBORP1",173,0)
.D ^DIR
"RTN","PSOBORP1",174,0)
.I ($G(DUOUT)=1)!($G(DTOUT)=1) S EXIT=1,Y="^" Q
"RTN","PSOBORP1",175,0)
.I Y="A" K PSOSEL("REJECT CODES") D Q
"RTN","PSOBORP1",176,0)
..S PSOSEL("REJECT CODES")="A"
"RTN","PSOBORP1",177,0)
..S PSOSEL("REJECT CODES","I")="INPATIENT"
"RTN","PSOBORP1",178,0)
..S PSOSEL("REJECT CODES","N")="NON-BILLABLE"
"RTN","PSOBORP1",179,0)
..S PSOSEL("REJECT CODES","R")="REJECT OVERRIDE"
"RTN","PSOBORP1",180,0)
..S PSOSEL("REJECT CODES","P")="PARTIAL FILL"
"RTN","PSOBORP1",181,0)
..S EXIT=1
"RTN","PSOBORP1",182,0)
.I Y="",$D(PSOSEL("REJECT CODES")) S EXIT=1 Q
"RTN","PSOBORP1",183,0)
.I Y="",'$D(PSOSEL("REJECT CODES")) S EXIT=0,I=0 Q
"RTN","PSOBORP1",184,0)
.I Y'="" S PSOSEL("REJECT CODES",Y)=$S(Y="I":"INPATIENT",Y="N":"NON-BILLABLE",Y="R":"REJECT OVERRIDE",Y="P":"PARTIAL FILL",1:"ALL")
"RTN","PSOBORP1",185,0)
;
"RTN","PSOBORP1",186,0)
Q Y
"RTN","PSOBORP1",187,0)
;
"RTN","PSOBORP1",188,0)
SELPHMST(PSOSEL) ;
"RTN","PSOBORP1",189,0)
;
"RTN","PSOBORP1",190,0)
; Select to include (S)pecific Pharmacist or (A)ll pharmacists
"RTN","PSOBORP1",191,0)
;
"RTN","PSOBORP1",192,0)
N DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y
"RTN","PSOBORP1",193,0)
K PSOPHARM,DIR
"RTN","PSOBORP1",194,0)
;
"RTN","PSOBORP1",195,0)
;First see if they want to enter individual divisions or ALL
"RTN","PSOBORP1",196,0)
S DIR(0)="S^S:SPECIFIC PHARMACIST(S);A:ALL PHARMACISTS"
"RTN","PSOBORP1",197,0)
S DIR("A")="Select Specific Pharmacist(s) or All Pharmacists"
"RTN","PSOBORP1",198,0)
S DIR("B")="ALL"
"RTN","PSOBORP1",199,0)
S DIR("L",1)="Select one of the following:"
"RTN","PSOBORP1",200,0)
S DIR("L",2)=""
"RTN","PSOBORP1",201,0)
S DIR("L",3)=" S Specific Pharmacist(s)"
"RTN","PSOBORP1",202,0)
S DIR("L",4)=" A All Pharmacists"
"RTN","PSOBORP1",203,0)
D ^DIR K DIR
"RTN","PSOBORP1",204,0)
;
"RTN","PSOBORP1",205,0)
;Check for "^" or timeout, otherwise define PSOPHARM
"RTN","PSOBORP1",206,0)
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
"RTN","PSOBORP1",207,0)
E S (PSOSEL("PHARMACIST"),PSOPHARM)=Y
"RTN","PSOBORP1",208,0)
;
"RTN","PSOBORP1",209,0)
;If pharmacist selected, ask prompt
"RTN","PSOBORP1",210,0)
I $G(PSOPHARM)="S" F D Q:Y="^"!(Y="")
"RTN","PSOBORP1",211,0)
.;
"RTN","PSOBORP1",212,0)
.;Prompt for entry
"RTN","PSOBORP1",213,0)
.K X S DIC(0)="QEAM",DIC=200,DIC("A")="Select Pharmacist: "
"RTN","PSOBORP1",214,0)
.S DIC("S")="I $D(^XUSEC(""PSORPH"",Y))"
"RTN","PSOBORP1",215,0)
.W ! D ^DIC
"RTN","PSOBORP1",216,0)
.;
"RTN","PSOBORP1",217,0)
.;Check for "^" or timeout
"RTN","PSOBORP1",218,0)
.I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPHARM S Y="^" Q
"RTN","PSOBORP1",219,0)
.;
"RTN","PSOBORP1",220,0)
.;Check for blank entry, quit if no previous selections
"RTN","PSOBORP1",221,0)
.I $G(X)="" S Y=$S($D(PSOPHARM)>9:"",1:"^") K:Y="^" PSOPHARM Q
"RTN","PSOBORP1",222,0)
.;
"RTN","PSOBORP1",223,0)
.;Handle Deletes
"RTN","PSOBORP1",224,0)
.I $D(PSOPHARM(+Y)) D Q:Y="^" I 1
"RTN","PSOBORP1",225,0)
..N P
"RTN","PSOBORP1",226,0)
..S P=Y ;Save Original Value
"RTN","PSOBORP1",227,0)
..S DIR(0)="S^Y:YES;N:NO",DIR("A")="Delete "_$P(P,U,2)_" from your list?"
"RTN","PSOBORP1",228,0)
..S DIR("B")="NO" D ^DIR
"RTN","PSOBORP1",229,0)
..I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPHARM S Y="^" Q
"RTN","PSOBORP1",230,0)
..I Y="Y" K PSOPHARM(+P),PSOPHARM("B",$P(P,U,2),+P)
"RTN","PSOBORP1",231,0)
..S Y=P ;Restore Original Value
"RTN","PSOBORP1",232,0)
..K P
"RTN","PSOBORP1",233,0)
.E D
"RTN","PSOBORP1",234,0)
..;Define new entries in PSOPHARM array
"RTN","PSOBORP1",235,0)
..S PSOPHARM(+Y)=Y
"RTN","PSOBORP1",236,0)
..S PSOPHARM("B",$P(Y,U,2),+Y)=""
"RTN","PSOBORP1",237,0)
.;
"RTN","PSOBORP1",238,0)
.;Display a list of selected providers
"RTN","PSOBORP1",239,0)
.I $D(PSOPHARM)>9 D
"RTN","PSOBORP1",240,0)
..N X
"RTN","PSOBORP1",241,0)
..W !,?2,"Selected:"
"RTN","PSOBORP1",242,0)
..S X="" F S X=$O(PSOPHARM("B",X)) Q:X="" W !,?10,X
"RTN","PSOBORP1",243,0)
..K X
"RTN","PSOBORP1",244,0)
.Q
"RTN","PSOBORP1",245,0)
;
"RTN","PSOBORP1",246,0)
K PSOPHARM("B")
"RTN","PSOBORP1",247,0)
M PSOSEL("PHARMACIST")=PSOPHARM
"RTN","PSOBORP1",248,0)
Q Y
"RTN","PSOBORP1",249,0)
;
"RTN","PSOBORP1",250,0)
SELPROV(PSOSEL) ;
"RTN","PSOBORP1",251,0)
;
"RTN","PSOBORP1",252,0)
;select to include (S)pecific Provider or (A)ll Providers
"RTN","PSOBORP1",253,0)
;
"RTN","PSOBORP1",254,0)
N DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y
"RTN","PSOBORP1",255,0)
K PSOPROV
"RTN","PSOBORP1",256,0)
;
"RTN","PSOBORP1",257,0)
;First see if they want to enter individual divisions or ALL
"RTN","PSOBORP1",258,0)
S DIR(0)="S^S:SPECIFIC PROVIDER(S);A:ALL PROVIDERS"
"RTN","PSOBORP1",259,0)
S DIR("A")="Select Specific Provider(s) or include ALL Providers"
"RTN","PSOBORP1",260,0)
S DIR("B")="ALL"
"RTN","PSOBORP1",261,0)
S DIR("L",1)="Select one of the following:"
"RTN","PSOBORP1",262,0)
S DIR("L",2)=""
"RTN","PSOBORP1",263,0)
S DIR("L",3)=" S Specific Provider(s)"
"RTN","PSOBORP1",264,0)
S DIR("L",4)=" A ALL Providers"
"RTN","PSOBORP1",265,0)
D ^DIR K DIR
"RTN","PSOBORP1",266,0)
;
"RTN","PSOBORP1",267,0)
;Check for "^" or timeout, otherwise define PSOPROV
"RTN","PSOBORP1",268,0)
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
"RTN","PSOBORP1",269,0)
E S (PSOSEL("PROVIDER"),PSOPROV)=Y
"RTN","PSOBORP1",270,0)
;
"RTN","PSOBORP1",271,0)
;If provider selected, ask prompt
"RTN","PSOBORP1",272,0)
I $G(PSOPROV)="S" F D Q:Y="^"!(Y="")
"RTN","PSOBORP1",273,0)
.;
"RTN","PSOBORP1",274,0)
.;Prompt for entry
"RTN","PSOBORP1",275,0)
.K X S DIC(0)="QEAM",DIC=200,DIC("A")="Select Provider: "
"RTN","PSOBORP1",276,0)
.S DIC("S")="I +$G(^VA(200,Y,""PS""))"
"RTN","PSOBORP1",277,0)
.W ! D ^DIC
"RTN","PSOBORP1",278,0)
.;
"RTN","PSOBORP1",279,0)
.;Check for "^" or timeout
"RTN","PSOBORP1",280,0)
.I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPROV S Y="^" Q
"RTN","PSOBORP1",281,0)
.;
"RTN","PSOBORP1",282,0)
.;Check for blank entry, quit if no previous selections
"RTN","PSOBORP1",283,0)
.I $G(X)="" S Y=$S($D(PSOPROV)>9:"",1:"^") K:Y="^" PSOPROV Q
"RTN","PSOBORP1",284,0)
.;
"RTN","PSOBORP1",285,0)
.;Handle Deletes
"RTN","PSOBORP1",286,0)
.I $D(PSOPROV(+Y)) D Q:Y="^" I 1
"RTN","PSOBORP1",287,0)
..N P
"RTN","PSOBORP1",288,0)
..S P=Y ;Save Original Value
"RTN","PSOBORP1",289,0)
..S DIR(0)="S^Y:YES;N:NO",DIR("A")="Delete "_$P(P,U,2)_" from your list?"
"RTN","PSOBORP1",290,0)
..S DIR("B")="NO" D ^DIR
"RTN","PSOBORP1",291,0)
..I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPROV S Y="^" Q
"RTN","PSOBORP1",292,0)
..I Y="Y" K PSOPROV(+P),PSOPROV("B",$P(P,U,2),+P)
"RTN","PSOBORP1",293,0)
..S Y=P ;Restore Original Value
"RTN","PSOBORP1",294,0)
..K P
"RTN","PSOBORP1",295,0)
.E D
"RTN","PSOBORP1",296,0)
..;Define new entries in PSOPROV array
"RTN","PSOBORP1",297,0)
..S PSOPROV(+Y)=Y
"RTN","PSOBORP1",298,0)
..S PSOPROV("B",$P(Y,U,2),+Y)=""
"RTN","PSOBORP1",299,0)
.;
"RTN","PSOBORP1",300,0)
.;Display a list of selected providers
"RTN","PSOBORP1",301,0)
.I $D(PSOPROV)>9 D
"RTN","PSOBORP1",302,0)
..N X
"RTN","PSOBORP1",303,0)
..W !,?2,"Selected:"
"RTN","PSOBORP1",304,0)
..S X="" F S X=$O(PSOPROV("B",X)) Q:X="" W !,?10,X
"RTN","PSOBORP1",305,0)
..K X
"RTN","PSOBORP1",306,0)
.Q
"RTN","PSOBORP1",307,0)
;
"RTN","PSOBORP1",308,0)
K PSOPROV("B")
"RTN","PSOBORP1",309,0)
M PSOSEL("PROVIDER")=PSOPROV
"RTN","PSOBORP1",310,0)
Q Y
"RTN","PSOBORP1",311,0)
;
"RTN","PSOBORP1",312,0)
PSOTOTAL(PSOSEL) ;
"RTN","PSOBORP1",313,0)
;
"RTN","PSOBORP1",314,0)
;Prompt to Include Group/Subtotal Report by (R) Pharmacy or (P)rovider/Provider
"RTN","PSOBORP1",315,0)
;ADDED BY BLD
"RTN","PSOBORP1",316,0)
;Returns ()
"RTN","PSOBORP1",317,0)
;
"RTN","PSOBORP1",318,0)
N Y,DUOUT,DTOUT,IBQUIT,DIROUT,DIR
"RTN","PSOBORP1",319,0)
N PSONPI
"RTN","PSOBORP1",320,0)
S DIR(0)="S^R:Pharmacist;P:Provider/Prescriber Name"
"RTN","PSOBORP1",321,0)
S DIR("A")="Group/Subtotal Report by (R)Pharmacist or (P)Provider"
"RTN","PSOBORP1",322,0)
;S DIR("B")="PHARMACIST"
"RTN","PSOBORP1",323,0)
D ^DIR
"RTN","PSOBORP1",324,0)
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" Q Y
"RTN","PSOBORP1",325,0)
S PSONPI=Y
"RTN","PSOBORP1",326,0)
;
"RTN","PSOBORP1",327,0)
Q Y
"RTN","PSOBORP1",328,0)
;
"RTN","PSOBORP1",329,0)
;
"RTN","PSOBORP1",330,0)
;Print Header 2 Line 1
"RTN","PSOBORP1",331,0)
;
"RTN","PSOBORP1",332,0)
; Input variable: PSORTYPE -> Report Type (1-7)
"RTN","PSOBORP1",333,0)
;
"RTN","PSOBORP1",334,0)
;
"RTN","PSOBORP1",335,0)
SELEXCEL() ; - Returns whether to capture data for Excel report.
"RTN","PSOBORP1",336,0)
; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data)
"RTN","PSOBORP1",337,0)
;
"RTN","PSOBORP1",338,0)
Q:PSOSEL("SUM_DETAIL")="S"
"RTN","PSOBORP1",339,0)
N EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT
"RTN","PSOBORP1",340,0)
;
"RTN","PSOBORP1",341,0)
S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W !
"RTN","PSOBORP1",342,0)
S DIR("A")="Do you want to capture report data for an Excel document"
"RTN","PSOBORP1",343,0)
S DIR("?")="^D HEXC"
"RTN","PSOBORP1",344,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q "^"
"RTN","PSOBORP1",345,0)
K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","PSOBORP1",346,0)
S EXCEL=0 I Y S EXCEL=1
"RTN","PSOBORP1",347,0)
;
"RTN","PSOBORP1",348,0)
;Display Excel display message
"RTN","PSOBORP1",349,0)
I EXCEL=1 D EXMSG
"RTN","PSOBORP1",350,0)
;
"RTN","PSOBORP1",351,0)
Q EXCEL
"RTN","PSOBORP1",352,0)
;
"RTN","PSOBORP1",353,0)
HEXC ; - 'Do you want to capture data...' prompt
"RTN","PSOBORP1",354,0)
W !!," Enter: 'Y' - To capture detail report data to transfer"
"RTN","PSOBORP1",355,0)
W !," to an Excel document"
"RTN","PSOBORP1",356,0)
W !," '<CR>' - To skip this option"
"RTN","PSOBORP1",357,0)
W !," '^' - To quit this option"
"RTN","PSOBORP1",358,0)
Q
"RTN","PSOBORP1",359,0)
;
"RTN","PSOBORP1",360,0)
;Display the message about capturing to an Excel file format
"RTN","PSOBORP1",361,0)
;
"RTN","PSOBORP1",362,0)
EXMSG ;
"RTN","PSOBORP1",363,0)
W !!?5,"Before continuing, please set up your terminal to capture the"
"RTN","PSOBORP1",364,0)
W !?5,"detail report data. On some terminals, this can be done by"
"RTN","PSOBORP1",365,0)
W !?5,"clicking on the 'Tools' menu above, then click on 'Capture"
"RTN","PSOBORP1",366,0)
W !?5,"Incoming Data' to save to Desktop. This report may take a"
"RTN","PSOBORP1",367,0)
W !?5,"while to run."
"RTN","PSOBORP1",368,0)
W !!?5,"Note: To avoid undesired wrapping of the data saved to the"
"RTN","PSOBORP1",369,0)
W !?5," file, please enter '0;256;999' at the 'DEVICE:' prompt.",!
"RTN","PSOBORP1",370,0)
Q
"RTN","PSOBORP1",371,0)
;
"RTN","PSOBORP1",372,0)
;
"RTN","PSOBORP1",373,0)
;Screen Pause
"RTN","PSOBORP1",374,0)
;
"RTN","PSOBORP1",375,0)
PAUSE ;
"RTN","PSOBORP1",376,0)
Q:$G(PSOSCR)'=1 S PSOUT=""
"RTN","PSOBORP1",377,0)
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSOUT=1
"RTN","PSOBORP1",378,0)
Q
"RTN","PSOBORP2")
0^3^B24488979
"RTN","PSOBORP2",1,0)
PSOBORP2 ;ALBANY/BLD - TRICARE-CHAMPVA BYPASS/OVERRIDE AUDIT REPORT ;7/1/2010
"RTN","PSOBORP2",2,0)
;;7.0;OUTPATIENT PHARMACY;**358,385,427,528**;DEC 1997;Build 8
"RTN","PSOBORP2",3,0)
;
"RTN","PSOBORP2",4,0)
;
"RTN","PSOBORP2",5,0)
Q
"RTN","PSOBORP2",6,0)
;
"RTN","PSOBORP2",7,0)
EN(RX,RFL,RESP) ;
"RTN","PSOBORP2",8,0)
;entry point to insert an entry in to the TRICARE-CHAMPVA Audit Report
"RTN","PSOBORP2",9,0)
; Passed In:
"RTN","PSOBORP2",10,0)
; RX = Prescription file (52) IEN
"RTN","PSOBORP2",11,0)
; RFL = Prescription refill number
"RTN","PSOBORP2",12,0)
; RESP = response back from ECME billing (from ECMESND^PSOBPSU1)
"RTN","PSOBORP2",13,0)
;
"RTN","PSOBORP2",14,0)
;
"RTN","PSOBORP2",15,0)
N REFILNBR,TRITXT
"RTN","PSOBORP2",16,0)
S TRITXT=$P(RESP,"^",2)
"RTN","PSOBORP2",17,0)
D AUDIT^PSOTRI(RX,RFL,,TRITXT,"N",$P(RESP,"^",3))
"RTN","PSOBORP2",18,0)
;
"RTN","PSOBORP2",19,0)
Q
"RTN","PSOBORP2",20,0)
;
"RTN","PSOBORP2",21,0)
RUNRPT(PSOSEL) ;
"RTN","PSOBORP2",22,0)
;
"RTN","PSOBORP2",23,0)
;THE INFORMATION FOR THE TRICARE-CHAMPVA OVERRIDE REPORT WILL BE GATHERED BY LOOPING THROUGH
"RTN","PSOBORP2",24,0)
;FILE 52.87 (PSO AUDIT LOG FILE) TO RETRIEVE THE INFORMATION BASED UPON THE FILTERING
"RTN","PSOBORP2",25,0)
;REQUIREMENTS IN ROUTINE PSOBORP0.
"RTN","PSOBORP2",26,0)
;
"RTN","PSOBORP2",27,0)
D EN^PSOBORP3(.PSOSEL)
"RTN","PSOBORP2",28,0)
Q
"RTN","PSOBORP2",29,0)
;
"RTN","PSOBORP2",30,0)
PROCESS(PSOSEL,PSOAUD) ;this will process file 52.87, the PSO AUDIT LOG
"RTN","PSOBORP2",31,0)
;
"RTN","PSOBORP2",32,0)
N ACTDT,BEGDT,ENDDT,DIVISION,ELTCTYP,ELTYPE,I,PHAMCST,PROVIDER
"RTN","PSOBORP2",33,0)
N PSOFILL,PSOD0,PSOD1,PSOARRAY,PSORX,REJCODE,REJIEN,TCTYPE
"RTN","PSOBORP2",34,0)
;
"RTN","PSOBORP2",35,0)
S BEGDT=PSOSEL("BEGIN DATE"),ENDDT=PSOSEL("END DATE")
"RTN","PSOBORP2",36,0)
S ACTDT=BEGDT,PSOD0=0
"RTN","PSOBORP2",37,0)
D PSOARRAY(.PSOARRAY)
"RTN","PSOBORP2",38,0)
F S ACTDT=$O(^PS(52.87,"E",ACTDT)) Q:ACTDT=""!(ACTDT\1>ENDDT) D
"RTN","PSOBORP2",39,0)
.F S PSOD0=$O(^PS(52.87,"E",ACTDT,PSOD0)) Q:PSOD0="" D
"RTN","PSOBORP2",40,0)
..;
"RTN","PSOBORP2",41,0)
..;quit if duplicate prescription
"RTN","PSOBORP2",42,0)
..S PSORX=$P(^PS(52.87,PSOD0,0),"^",2)
"RTN","PSOBORP2",43,0)
..S PSOFILL=$P(^PS(52.87,PSOD0,0),"^",3)
"RTN","PSOBORP2",44,0)
..S PSOD1=PSOARRAY(PSORX,PSOFILL)
"RTN","PSOBORP2",45,0)
..;if they are different entries in File #52.87, and if ACTDT is the same as the
"RTN","PSOBORP2",46,0)
..; DATE OF ACTION (#15), then quit it's a duplicate entry
"RTN","PSOBORP2",47,0)
..I PSOD0'=PSOD1 I ACTDT=$P(^PS(52.87,PSOD1,1),"^",5) Q
"RTN","PSOBORP2",48,0)
..;
"RTN","PSOBORP2",49,0)
..;quit if division not selected or not all
"RTN","PSOBORP2",50,0)
..S DIVISION=$P(^PS(52.87,PSOD0,0),"^",5)
"RTN","PSOBORP2",51,0)
..I PSOSEL("DIVISION")'="A" Q:'$D(PSOSEL("DIVISION",DIVISION))
"RTN","PSOBORP2",52,0)
..S DIVISION=$P(^PS(59,DIVISION,0),"^",1)
"RTN","PSOBORP2",53,0)
..;
"RTN","PSOBORP2",54,0)
..;quit if eligibility type not selected or not all
"RTN","PSOBORP2",55,0)
..S ELTYPE=$P(^PS(52.87,PSOD0,1),"^",3)
"RTN","PSOBORP2",56,0)
..Q:'$D(PSOSEL("ELIG_TYPE",ELTYPE))
"RTN","PSOBORP2",57,0)
..S ELTYPE=$S(ELTYPE="T":"TRICARE",ELTYPE="C":"CHAMPVA",1:"ALL")
"RTN","PSOBORP2",58,0)
..;
"RTN","PSOBORP2",59,0)
..;quit if audit type not selected or not all
"RTN","PSOBORP2",60,0)
..S TCTYPE=$P(^PS(52.87,PSOD0,1),"^",2)
"RTN","PSOBORP2",61,0)
..Q:'$D(PSOSEL("REJECT CODES",TCTYPE))
"RTN","PSOBORP2",62,0)
..S TCTYPE=$S(TCTYPE="I":"INPATIENT",TCTYPE="N":"NON-BILLABLE",TCTYPE="R":"REJECT OVERRIDE",TCTYPE="P":"PARTIAL FILL",1:"ALL")
"RTN","PSOBORP2",63,0)
..S ELTCTYP=ELTYPE_" "_TCTYPE
"RTN","PSOBORP2",64,0)
..;
"RTN","PSOBORP2",65,0)
..;quit if specific pharmacist not selected or not all
"RTN","PSOBORP2",66,0)
..S PHAMCST=$P(^PS(52.87,PSOD0,1),"^",4)
"RTN","PSOBORP2",67,0)
..I PHAMCST'="",PSOSEL("PHARMACIST")'="A" Q:'$D(PSOSEL("PHARMACIST",PHAMCST))
"RTN","PSOBORP2",68,0)
..S PHAMCST=$P(^VA(200,PHAMCST,0),"^",1)
"RTN","PSOBORP2",69,0)
..;
"RTN","PSOBORP2",70,0)
..;quit if specific provider not selected or not all
"RTN","PSOBORP2",71,0)
..S PROVIDER=$P(^PS(52.87,PSOD0,0),"^",6)
"RTN","PSOBORP2",72,0)
..I PSOSEL("PROVIDER")'="A" Q:'$D(PSOSEL("PROVIDER",PROVIDER))
"RTN","PSOBORP2",73,0)
..S PROVIDER=$P(^VA(200,PROVIDER,0),"^",1)
"RTN","PSOBORP2",74,0)
..;
"RTN","PSOBORP2",75,0)
..;summary report
"RTN","PSOBORP2",76,0)
..I PSOSEL("SUM_DETAIL")="D"!(PSOSEL("SUM_DETAIL")="S") D
"RTN","PSOBORP2",77,0)
...;totals by provider
"RTN","PSOBORP2",78,0)
...I PSOSEL("TOTALS BY")="P" D Q
"RTN","PSOBORP2",79,0)
....S PSOAUD(DIVISION,ELTCTYP,PROVIDER,ACTDT,0)=^PS(52.87,PSOD0,0)
"RTN","PSOBORP2",80,0)
....S PSOAUD(DIVISION,ELTCTYP,PROVIDER,ACTDT,1)=^PS(52.87,PSOD0,1)
"RTN","PSOBORP2",81,0)
....S PSOAUD(DIVISION,ELTCTYP,PROVIDER,ACTDT,2)=^PS(52.87,PSOD0,2)
"RTN","PSOBORP2",82,0)
...;
"RTN","PSOBORP2",83,0)
...;totals by pharmacist and Division
"RTN","PSOBORP2",84,0)
...I PSOSEL("TOTALS BY")="R" D Q
"RTN","PSOBORP2",85,0)
....S PSOAUD(DIVISION,ELTCTYP,PHAMCST,ACTDT,0)=^PS(52.87,PSOD0,0)
"RTN","PSOBORP2",86,0)
....S PSOAUD(DIVISION,ELTCTYP,PHAMCST,ACTDT,1)=^PS(52.87,PSOD0,1)
"RTN","PSOBORP2",87,0)
....S PSOAUD(DIVISION,ELTCTYP,PHAMCST,ACTDT,2)=^PS(52.87,PSOD0,2)
"RTN","PSOBORP2",88,0)
..;
"RTN","PSOBORP2",89,0)
..S REJIEN=0,REJCODE=""
"RTN","PSOBORP2",90,0)
..F S REJIEN=$O(^PS(52.87,PSOD0,3,REJIEN)) Q:'REJIEN D
"RTN","PSOBORP2",91,0)
...I PSOSEL("TOTALS BY")="P" S PSOAUD(DIVISION,ELTCTYP,PROVIDER,ACTDT,3,REJIEN)=^PS(52.87,PSOD0,3,REJIEN,0)
"RTN","PSOBORP2",92,0)
...I PSOSEL("TOTALS BY")="R" S PSOAUD(DIVISION,ELTCTYP,PHAMCST,ACTDT,3,REJIEN)=^PS(52.87,PSOD0,3,REJIEN,0)
"RTN","PSOBORP2",93,0)
;
"RTN","PSOBORP2",94,0)
Q
"RTN","PSOBORP2",95,0)
;
"RTN","PSOBORP2",96,0)
END ;
"RTN","PSOBORP2",97,0)
I 'PSOEXCEL W !!!!,"REPORT HAS FINISHED"
"RTN","PSOBORP2",98,0)
K DIVRXTOT,DIVTOT,GRDRXTOT,GROUPCNT,GRDTOT,PAGE,PROV,PSODIV,PSOCNT,PSORPTNM,PSORTYPE,PSOTOTAL,TC,TCT
"RTN","PSOBORP2",99,0)
Q
"RTN","PSOBORP2",100,0)
;
"RTN","PSOBORP2",101,0)
GETPARAM(PSOFLDNO,PSODUZ) ;
"RTN","PSOBORP2",102,0)
Q $$GET^XPAR(PSODUZ_";VA(200,","PSOS USRSCR",PSOFLDNO,"I")
"RTN","PSOBORP2",103,0)
;
"RTN","PSOBORP2",104,0)
;
"RTN","PSOBORP2",105,0)
UP(PSVAR) ;converts to upper case
"RTN","PSOBORP2",106,0)
Q $TR(PSVAR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
"RTN","PSOBORP2",107,0)
;
"RTN","PSOBORP2",108,0)
;
"RTN","PSOBORP2",109,0)
;will build an of array of RX's to eliminate duplicates.
"RTN","PSOBORP2",110,0)
PSOARRAY(PSOARRAY) ;
"RTN","PSOBORP2",111,0)
N ACTDT,BEGDT,ENDDT,DIVISION,I,PHAMCST,PROVIDER,PSOD0,PSOFILL,REJCODE,TCTYPE,REJIEN,TCTYPE
"RTN","PSOBORP2",112,0)
S BEGDT=PSOSEL("BEGIN DATE"),ENDDT=PSOSEL("END DATE")
"RTN","PSOBORP2",113,0)
S ACTDT=BEGDT,PSOD0=0
"RTN","PSOBORP2",114,0)
F S ACTDT=$O(^PS(52.87,"E",ACTDT)) Q:ACTDT=""!(ACTDT\1>ENDDT) D
"RTN","PSOBORP2",115,0)
.F S PSOD0=$O(^PS(52.87,"E",ACTDT,PSOD0)) Q:PSOD0="" D
"RTN","PSOBORP2",116,0)
..S PSOFILL=$P(^PS(52.87,PSOD0,0),"^",3)
"RTN","PSOBORP2",117,0)
..S PSOARRAY($P(^PS(52.87,PSOD0,0),"^",2),PSOFILL)=PSOD0
"RTN","PSOBORP2",118,0)
Q
"RTN","PSOBORP3")
0^4^B198511557
"RTN","PSOBORP3",1,0)
PSOBORP3 ;ALBANY/BLD - TRICARE-CHAMPVA BYPASS/OVERRIDE AUDIT REPORT ;7/1/2010
"RTN","PSOBORP3",2,0)
;;7.0;OUTPATIENT PHARMACY;**358,359,385,427,528**;DEC 1997;Build 8
"RTN","PSOBORP3",3,0)
;
"RTN","PSOBORP3",4,0)
;Uses API
"RTN","PSOBORP3",5,0)
;this routine will process the TRICARE-CHAMPVA Override Report based on the filtering criteria in routine PSOBORP0
"RTN","PSOBORP3",6,0)
;
"RTN","PSOBORP3",7,0)
;
"RTN","PSOBORP3",8,0)
EN(PSOSEL) ;
"RTN","PSOBORP3",9,0)
;
"RTN","PSOBORP3",10,0)
;THE INFORMATION FOR THE TRICARE-CHAMPVA OVERRIDE REPORT WILL BE GATHERED BY LOOPING THROUGH
"RTN","PSOBORP3",11,0)
;FILE 52.87 (PSO AUDIT LOG FILE) TO RETRIEVE THE INFORMATION BASED UPON THE FILTERING
"RTN","PSOBORP3",12,0)
;REQUIREMENTS IN ROUTINE PSOBORP0.
"RTN","PSOBORP3",13,0)
;
"RTN","PSOBORP3",14,0)
N ACTDT,AMT,BEGDT,DASH,DETSUM,ENDDT,EQUAL,HDR1,HDR2,HDR3,HDR4,HDR5,HDR6,HDR7,MEAN,PAGE,PAGENBR,RXCNT
"RTN","PSOBORP3",15,0)
N PSONOW,RJHDR,SPACE,STAR,PSOAUD,SUBTOTAL,SUBTOT,PROVTOT,PRORXTOT
"RTN","PSOBORP3",16,0)
D INIT
"RTN","PSOBORP3",17,0)
D PROCESS^PSOBORP2(.PSOSEL,.PSOAUD) ;process file 52.87 (Audit File)
"RTN","PSOBORP3",18,0)
W:'PSOEXCEL @IOF D HDR
"RTN","PSOBORP3",19,0)
I PSOSEL("SUM_DETAIL")="S" D SUMMARY(.PSOSEL,.PSOAUD)
"RTN","PSOBORP3",20,0)
I PSOSEL("SUM_DETAIL")="D" D DETAIL(.PSOSEL,.PSOAUD)
"RTN","PSOBORP3",21,0)
;
"RTN","PSOBORP3",22,0)
D END^PSOBORP2
"RTN","PSOBORP3",23,0)
Q
"RTN","PSOBORP3",24,0)
;
"RTN","PSOBORP3",25,0)
DETAIL(PSOSEL,PSOAUD) ;for detail report
"RTN","PSOBORP3",26,0)
;
"RTN","PSOBORP3",27,0)
N PAGELOC,AMT,PROV
"RTN","PSOBORP3",28,0)
N GRDTOTAL,DIVISION,DIVTOT,DIVRXTOT,RXCNT,GRDRXTOT,ACTDT,TCTOTAL,TCTYPE,PROVIDER,PROVTOT,PROVRXT,SUBTOT,SUBTOTAL
"RTN","PSOBORP3",29,0)
;
"RTN","PSOBORP3",30,0)
I PSOEXCEL D EDETAIL(.PSOSEL,.PSOAUD) Q ;if Excel format chosen
"RTN","PSOBORP3",31,0)
S PAGENBR=1
"RTN","PSOBORP3",32,0)
D DETHDR
"RTN","PSOBORP3",33,0)
;
"RTN","PSOBORP3",34,0)
S (GRDTOTAL,DIVISION,DIVTOT,DIVRXTOT,RXCNT,GRDRXTOT,ACTDT,TCTOTAL,TCTYPE,PROVIDER,PROVTOT,PROVRXT,PRORXTOT,PROVTOT,SUBTOTAL)=""
"RTN","PSOBORP3",35,0)
;
"RTN","PSOBORP3",36,0)
I PSOSEL("TOTALS BY")="P"!(PSOSEL("TOTALS BY")="R") D Q
"RTN","PSOBORP3",37,0)
.F S DIVISION=$O(PSOAUD(DIVISION)) Q:DIVISION=""!($G(PSOUT)) D
"RTN","PSOBORP3",38,0)
..S (PROVTOT,PRORXTOT,DIVTOT,DIVRXTOT)=""
"RTN","PSOBORP3",39,0)
..I ($Y+8)>IOSL D DETHDR Q:$G(PSOUT)
"RTN","PSOBORP3",40,0)
..W !!,$E(DASH,1,110)
"RTN","PSOBORP3",41,0)
..W !,"DIVISION: ",DIVISION
"RTN","PSOBORP3",42,0)
..F S TCTYPE=$O(PSOAUD(DIVISION,TCTYPE)) Q:TCTYPE=""!($G(PSOUT)) D
"RTN","PSOBORP3",43,0)
...S TCT=TCTYPE,(TCRXTOT,TCTOTAL)="" D TCHDR(TCT)
"RTN","PSOBORP3",44,0)
...F S PROVIDER=$O(PSOAUD(DIVISION,TCTYPE,PROVIDER)) Q:PROVIDER=""!($G(PSOUT)) D
"RTN","PSOBORP3",45,0)
....S (PROVTOT,PRORXTOT)=""
"RTN","PSOBORP3",46,0)
....F S ACTDT=$O(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT)) Q:ACTDT=""!($G(PSOUT)) D
"RTN","PSOBORP3",47,0)
.....S PROV=PROVIDER
"RTN","PSOBORP3",48,0)
.....S AMT=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",9)
"RTN","PSOBORP3",49,0)
.....S PROVTOT=$FN(PROVTOT+AMT,"T",2)
"RTN","PSOBORP3",50,0)
.....S PRORXTOT=PRORXTOT+1
"RTN","PSOBORP3",51,0)
.....S TCTOTAL=$FN(TCTOTAL+AMT,"T",2)
"RTN","PSOBORP3",52,0)
.....S TCRXTOT=TCRXTOT+1
"RTN","PSOBORP3",53,0)
.....S DIVTOT=$FN(DIVTOT+AMT,"T",2)
"RTN","PSOBORP3",54,0)
.....S DIVRXTOT=DIVRXTOT+1
"RTN","PSOBORP3",55,0)
.....S GRDTOTAL=$FN(GRDTOTAL+AMT,"T",2)
"RTN","PSOBORP3",56,0)
.....S GRDRXTOT=GRDRXTOT+1
"RTN","PSOBORP3",57,0)
.....Q:$G(PSOUT) D:($Y+8)>IOSL DETHDR Q:$G(PSOUT) D TCDSUMP(TCT,PROV,ACTDT) ;detail print
"RTN","PSOBORP3",58,0)
....Q:$G(PSOUT) D:($Y+8)>IOSL DETHDR Q:$G(PSOUT) D PROVTOT(TCT,PROV,PROVTOT,PRORXTOT)
"RTN","PSOBORP3",59,0)
...Q:$G(PSOUT) D:($Y+8)>IOSL DETHDR Q:$G(PSOUT) D TCTOT(TCTOTAL,TCRXTOT,TCT)
"RTN","PSOBORP3",60,0)
..Q:$G(PSOUT) D:($Y+8)>IOSL DETHDR Q:$G(PSOUT) D DIVTOTP(DIVTOT,DIVRXTOT)
"RTN","PSOBORP3",61,0)
.Q:$G(PSOUT) D:($Y+8)>IOSL DETHDR Q:$G(PSOUT) D GRDTOTP(GRDTOTAL,GRDRXTOT)
"RTN","PSOBORP3",62,0)
;
"RTN","PSOBORP3",63,0)
Q
"RTN","PSOBORP3",64,0)
;
"RTN","PSOBORP3",65,0)
EDETAIL(PSOSEL,PSOAUD) ;for detail report
"RTN","PSOBORP3",66,0)
;
"RTN","PSOBORP3",67,0)
N PAGELOC,AMT
"RTN","PSOBORP3",68,0)
N GRDTOTAL,DIVISION,DIVTOT,DIVRXTOT,RXCNT,GRDRXTOT,ACTDT,TCTOTAL,TCTYPE,PROVIDER,PROVTOT,PROVRXT,SUBTOT,SUBTOTAL,PROV
"RTN","PSOBORP3",69,0)
;
"RTN","PSOBORP3",70,0)
S PAGENBR=1
"RTN","PSOBORP3",71,0)
D DETHDR
"RTN","PSOBORP3",72,0)
;
"RTN","PSOBORP3",73,0)
S (GRDTOTAL,DIVISION,DIVTOT,DIVRXTOT,RXCNT,GRDRXTOT,ACTDT,TCTOTAL,TCTYPE,PROVIDER,PROVTOT,PROVRXT,SUBTOT,SUBTOTAL)=""
"RTN","PSOBORP3",74,0)
;
"RTN","PSOBORP3",75,0)
I PSOSEL("TOTALS BY")="P"!(PSOSEL("TOTALS BY")="R") D Q
"RTN","PSOBORP3",76,0)
.F S DIVISION=$O(PSOAUD(DIVISION)) Q:DIVISION=""!($G(PSOUT)) D
"RTN","PSOBORP3",77,0)
..F S TCTYPE=$O(PSOAUD(DIVISION,TCTYPE)) Q:TCTYPE=""!($G(PSOUT)) D
"RTN","PSOBORP3",78,0)
...S TCT=TCTYPE
"RTN","PSOBORP3",79,0)
...F S PROVIDER=$O(PSOAUD(DIVISION,TCTYPE,PROVIDER)) Q:PROVIDER=""!($G(PSOUT)) D
"RTN","PSOBORP3",80,0)
....F S ACTDT=$O(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT)) Q:ACTDT=""!($G(PSOUT)) D
"RTN","PSOBORP3",81,0)
.....S PROV=PROVIDER
"RTN","PSOBORP3",82,0)
.....S AMT=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",9)
"RTN","PSOBORP3",83,0)
.....Q:$G(PSOUT) D TCDSUMP(TCTYPE,PROV,ACTDT) ;detail print
"RTN","PSOBORP3",84,0)
....Q:$G(PSOUT)
"RTN","PSOBORP3",85,0)
...Q:$G(PSOUT)
"RTN","PSOBORP3",86,0)
..Q:$G(PSOUT)
"RTN","PSOBORP3",87,0)
.Q:$G(PSOUT)
"RTN","PSOBORP3",88,0)
;
"RTN","PSOBORP3",89,0)
Q
"RTN","PSOBORP3",90,0)
;
"RTN","PSOBORP3",91,0)
SUMMARY(PSOSEL,PSOAUD) ;for summary report
"RTN","PSOBORP3",92,0)
;
"RTN","PSOBORP3",93,0)
N AMT,ACTDT,ACTDATE,DIVISION,PROVIDER,PHAMCST,PAGELOC,PROVIDER,TCTOTAL,TCTYPE,RXTOTAL,RXCNT,GRDTOTAL,SUBTOT,MEAN
"RTN","PSOBORP3",94,0)
;
"RTN","PSOBORP3",95,0)
S PAGENBR=1
"RTN","PSOBORP3",96,0)
D SUMHDR
"RTN","PSOBORP3",97,0)
S (GRDTOTAL,DIVISION,DIVTOT,DIVRXTOT,RXCNT,GRDRXTOT,ACTDT,TCTOTAL,TCRXTOT,TCTYPE,PROVIDER,PROVTOT,PRORXTOT,SUBTOTAL)=""
"RTN","PSOBORP3",98,0)
;
"RTN","PSOBORP3",99,0)
;subtotals by provider
"RTN","PSOBORP3",100,0)
I PSOSEL("TOTALS BY")="P"!(PSOSEL("TOTALS BY")="R") D
"RTN","PSOBORP3",101,0)
.F S DIVISION=$O(PSOAUD(DIVISION)) Q:DIVISION=""!($G(PSOUT)) D
"RTN","PSOBORP3",102,0)
..S (PROVTOT,PRORXTOT,RXCNT,DIVTOT,DIVRXTOT)=""
"RTN","PSOBORP3",103,0)
..I ($Y+8)>IOSL D SUMHDR Q:$G(PSOUT)
"RTN","PSOBORP3",104,0)
..W !!,$E(DASH,1,110)
"RTN","PSOBORP3",105,0)
..W !,"DIVISION: ",DIVISION
"RTN","PSOBORP3",106,0)
..F S TCTYPE=$O(PSOAUD(DIVISION,TCTYPE)) Q:TCTYPE=""!($G(PSOUT)) D
"RTN","PSOBORP3",107,0)
...S TCT=TCTYPE,(TCRXTOT,TCTOTAL)="" D TCHDR(TCT)
"RTN","PSOBORP3",108,0)
...F S PROVIDER=$O(PSOAUD(DIVISION,TCTYPE,PROVIDER)) Q:PROVIDER=""!($G(PSOUT)) D
"RTN","PSOBORP3",109,0)
....S (PROVTOT,PRORXTOT)=0
"RTN","PSOBORP3",110,0)
....F S ACTDT=$O(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT)) Q:ACTDT=""!($G(PSOUT)) D
"RTN","PSOBORP3",111,0)
.....S PROV=PROVIDER
"RTN","PSOBORP3",112,0)
.....S AMT=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",9)
"RTN","PSOBORP3",113,0)
.....S PROVTOT=$FN(PROVTOT+AMT,"T",2)
"RTN","PSOBORP3",114,0)
.....S PRORXTOT=PRORXTOT+1
"RTN","PSOBORP3",115,0)
.....S TCTOTAL=$FN(TCTOTAL+AMT,"T",2)
"RTN","PSOBORP3",116,0)
.....S TCRXTOT=TCRXTOT+1
"RTN","PSOBORP3",117,0)
.....S DIVTOT=$FN(DIVTOT+AMT,"T",2)
"RTN","PSOBORP3",118,0)
.....S DIVRXTOT=DIVRXTOT+1
"RTN","PSOBORP3",119,0)
.....S GRDTOTAL=$FN(GRDTOTAL+AMT,"T",2)
"RTN","PSOBORP3",120,0)
.....S GRDRXTOT=GRDRXTOT+1
"RTN","PSOBORP3",121,0)
....Q:$G(PSOUT) D:($Y+8)>IOSL SUMHDR Q:$G(PSOUT) D TCSSUMP(PROVTOT,PRORXTOT,TCT,PROV) ;summary print
"RTN","PSOBORP3",122,0)
...Q:$G(PSOUT) D:($Y+8)>IOSL SUMHDR Q:$G(PSOUT) D TCTOT(TCTOTAL,TCRXTOT,TCT)
"RTN","PSOBORP3",123,0)
..Q:$G(PSOUT) D:($Y+8)>IOSL SUMHDR Q:$G(PSOUT) D DIVTOTP(DIVTOT,DIVRXTOT)
"RTN","PSOBORP3",124,0)
.Q:$G(PSOUT) D:($Y+8)>IOSL SUMHDR Q:$G(PSOUT) D GRDTOTP(GRDTOTAL,GRDRXTOT)
"RTN","PSOBORP3",125,0)
;
"RTN","PSOBORP3",126,0)
Q
"RTN","PSOBORP3",127,0)
;
"RTN","PSOBORP3",128,0)
SUMHDR ;
"RTN","PSOBORP3",129,0)
;this will print the header and page breaks for summary report.
"RTN","PSOBORP3",130,0)
;
"RTN","PSOBORP3",131,0)
;
"RTN","PSOBORP3",132,0)
I PAGENBR>1 D PAUSE^PSOBORP1 Q:$G(PSOUT) W @IOF
"RTN","PSOBORP3",133,0)
S PAGELOC=132-($L(PAGE)+$L(PAGENBR))
"RTN","PSOBORP3",134,0)
W !,HDR1,?PAGELOC,PAGE,PAGENBR S PAGENBR=PAGENBR+1
"RTN","PSOBORP3",135,0)
W !,HDR2,!,HDR3,!,HDR4,!,HDR5 W !,$E(EQUAL,1,110)
"RTN","PSOBORP3",136,0)
;
"RTN","PSOBORP3",137,0)
Q
"RTN","PSOBORP3",138,0)
;
"RTN","PSOBORP3",139,0)
DETHDR ;
"RTN","PSOBORP3",140,0)
;this will print the header and page breaks for the detail report
"RTN","PSOBORP3",141,0)
;
"RTN","PSOBORP3",142,0)
I PAGENBR>1,PSOEXCEL Q ;if Excel spreadsheet format
"RTN","PSOBORP3",143,0)
;
"RTN","PSOBORP3",144,0)
I PAGENBR>1 D PAUSE^PSOBORP1 Q:$G(PSOUT) W @IOF
"RTN","PSOBORP3",145,0)
S PAGELOC=132-($L(PAGE)+$L(PAGENBR))
"RTN","PSOBORP3",146,0)
I 'PSOEXCEL D
"RTN","PSOBORP3",147,0)
.W !,HDR1,?PAGELOC,PAGE,PAGENBR S PAGENBR=PAGENBR+1
"RTN","PSOBORP3",148,0)
.W !,HDR2,!,HDR3,!,HDR4,!,HDR5,!,$E(EQUAL,1,110),!,HDR6,!,HDR7,!,$E(EQUAL,1,110)
"RTN","PSOBORP3",149,0)
;
"RTN","PSOBORP3",150,0)
I PSOEXCEL D
"RTN","PSOBORP3",151,0)
.W !,"DIVISION"_"^"_"PT ELIG"_"^"_"TYPE"_"^"_"PROVIDER"_"^"_"BENEFICIARY NAME"_"^"_"ID"_"^"_"RX#"_"^"_"REF/ECME#"_"^"_"RX DATE"_"^"_"FILL LOC"_"^"_"STATUS"_"^"_"ACTION DATE"_"^"_"USER NAME"_"^"_"$BILLED"
"RTN","PSOBORP3",152,0)
.W "^"_"QTY"_"^"_"NDC#"_"^"_"DRUG"_"^"_"REJECT CODE(S)"_"^"_"REJECT CODE"_"^"_"REJECT EXPLANATION"_"^"_"JUSTIFICATION"
"RTN","PSOBORP3",153,0)
;
"RTN","PSOBORP3",154,0)
Q
"RTN","PSOBORP3",155,0)
;
"RTN","PSOBORP3",156,0)
PROVTOT(TCT,PROVIDER,PROVTOT,PROVRXT) ;prints totals by provider
"RTN","PSOBORP3",157,0)
;
"RTN","PSOBORP3",158,0)
Q:PSOEXCEL ;if Excel spreadsheet format
"RTN","PSOBORP3",159,0)
;
"RTN","PSOBORP3",160,0)
Q:TCTYPE="TRICARE INPATIENT"!(TCTYPE="CHAMPVA INPATIENT")
"RTN","PSOBORP3",161,0)
W !!,?10,PROV
"RTN","PSOBORP3",162,0)
W !,?10,"SUBTOTALS",?51,PROVTOT
"RTN","PSOBORP3",163,0)
W !,?10,"RX COUNT",?51,PROVRXT
"RTN","PSOBORP3",164,0)
W !,?10,"MEAN",?51,$FN(PROVTOT/PROVRXT,"T",2),!
"RTN","PSOBORP3",165,0)
S (PROVRXT,PROVTOT)=""
"RTN","PSOBORP3",166,0)
;
"RTN","PSOBORP3",167,0)
Q
"RTN","PSOBORP3",168,0)
;
"RTN","PSOBORP3",169,0)
;
"RTN","PSOBORP3",170,0)
TCTOT(TCTOTAL,TCRXTOT,TCTYPE) ;
"RTN","PSOBORP3",171,0)
;print tctypes totals
"RTN","PSOBORP3",172,0)
;
"RTN","PSOBORP3",173,0)
Q:PSOEXCEL ;if Excel spreadsheet format
"RTN","PSOBORP3",174,0)
;
"RTN","PSOBORP3",175,0)
W !!,?5,TCTYPE
"RTN","PSOBORP3",176,0)
W !,?5,"SUBTOTALS",?51,TCTOTAL
"RTN","PSOBORP3",177,0)
W !,?5,"RX COUNT",?51,TCRXTOT
"RTN","PSOBORP3",178,0)
W !,?5,"MEAN",?51,$FN(TCTOTAL/TCRXTOT,"T",2)
"RTN","PSOBORP3",179,0)
;
"RTN","PSOBORP3",180,0)
;
"RTN","PSOBORP3",181,0)
Q
"RTN","PSOBORP3",182,0)
;
"RTN","PSOBORP3",183,0)
DIVTOTP(DIVTOT,DIVRXTOT) ;
"RTN","PSOBORP3",184,0)
;print the totals for a division
"RTN","PSOBORP3",185,0)
;
"RTN","PSOBORP3",186,0)
Q:PSOEXCEL ;if Excel spreadsheet format
"RTN","PSOBORP3",187,0)
;
"RTN","PSOBORP3",188,0)
W !!,"DIVISION ",DIVISION,?51,$E(DASH,1,13)
"RTN","PSOBORP3",189,0)
W !,"SUBTOTALS",?51,DIVTOT
"RTN","PSOBORP3",190,0)
W !,"RX COUNT",?51,DIVRXTOT
"RTN","PSOBORP3",191,0)
W !,"MEAN",?51,$FN(DIVTOT/DIVRXTOT,"T",2)
"RTN","PSOBORP3",192,0)
;
"RTN","PSOBORP3",193,0)
Q
"RTN","PSOBORP3",194,0)
;
"RTN","PSOBORP3",195,0)
GRDTOTP(GRDTOTAL,GRDRXTOT) ;
"RTN","PSOBORP3",196,0)
;
"RTN","PSOBORP3",197,0)
Q:PSOEXCEL ;if Excel spreadsheet format
"RTN","PSOBORP3",198,0)
;
"RTN","PSOBORP3",199,0)
N I
"RTN","PSOBORP3",200,0)
;
"RTN","PSOBORP3",201,0)
I '$D(PSOAUD) W !!,?26,"NO INFORMATION FOUND..." Q
"RTN","PSOBORP3",202,0)
F I=1:1:2 W !,?51,$E(DASH,1,13)
"RTN","PSOBORP3",203,0)
W !!!,"GRAND TOTALS",?51,GRDTOTAL
"RTN","PSOBORP3",204,0)
W !,"RX COUNT",?51,GRDRXTOT
"RTN","PSOBORP3",205,0)
W !,"MEAN",?51,$FN(GRDTOTAL/GRDRXTOT,"T",2)
"RTN","PSOBORP3",206,0)
W !,?51,$E(DASH,1,13)
"RTN","PSOBORP3",207,0)
;
"RTN","PSOBORP3",208,0)
Q
"RTN","PSOBORP3",209,0)
;
"RTN","PSOBORP3",210,0)
;
"RTN","PSOBORP3",211,0)
TCDSUMP(TCTYPE,PROVIDER,ACTDT) ;print the summary
"RTN","PSOBORP3",212,0)
;
"RTN","PSOBORP3",213,0)
N AMTBILL,DFN,NAME,ID,REFILL,RXNBR,RX,ECMENBR,RXDATE,RXINFO,RXQTY,NDCNBR,RXDRUG,VADM,USER,TRIJUST,PTELIG,REJ,RTYPE
"RTN","PSOBORP3",214,0)
S RJHDR=$E(STAR,1,30)_$E(SPACE,1,3)_TCTYPE_$E(SPACE,1,3)_$E(STAR,1,(57-$L(TCTYPE)))
"RTN","PSOBORP3",215,0)
S DFN=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",4)
"RTN","PSOBORP3",216,0)
D DEM^VADPT
"RTN","PSOBORP3",217,0)
S NAME=VADM(1)
"RTN","PSOBORP3",218,0)
S ID=$P(VADM(2),"^",1),ID=$E(ID,$L(ID)-3,999)
"RTN","PSOBORP3",219,0)
S RXNBR=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",2)
"RTN","PSOBORP3",220,0)
S RX=$$GET1^DIQ(52,RXNBR,.01)
"RTN","PSOBORP3",221,0)
S REFILL=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",3)
"RTN","PSOBORP3",222,0)
S ECMENBR=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",10) I ECMENBR="" S ECMENBR="N/A"
"RTN","PSOBORP3",223,0)
S ECMENBR=REFILL_"/"_ECMENBR
"RTN","PSOBORP3",224,0)
S RXDATE=$$DATTIM($P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,1)),"^",6))
"RTN","PSOBORP3",225,0)
S RXINFO=$$RXINFO(RXNBR)
"RTN","PSOBORP3",226,0)
S USER=$P(^VA(200,$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,1)),"^",4),0),"^",1)
"RTN","PSOBORP3",227,0)
S AMTBILL=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",9)
"RTN","PSOBORP3",228,0)
S RXQTY=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",11)
"RTN","PSOBORP3",229,0)
S NDCNBR=$TR($P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",7),"-","")
"RTN","PSOBORP3",230,0)
S RXDRUG=$E($P($G(^PSDRUG($P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,0)),"^",8),0)),"^",1),1,24)
"RTN","PSOBORP3",231,0)
S TRIJUST=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,2)),"^",1)
"RTN","PSOBORP3",232,0)
S PTELIG=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,1)),"^",3)
"RTN","PSOBORP3",233,0)
S REJ=$P($G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,1)),"^",2),RTYPE=$S(REJ="I":"INPATIENT",REJ="N":"NON-BILLABLE",REJ="R":"REJECT OVERRIDE",REJ="P":"PARTIAL FILL",1:"")
"RTN","PSOBORP3",234,0)
;
"RTN","PSOBORP3",235,0)
;for standard output
"RTN","PSOBORP3",236,0)
I 'PSOEXCEL D
"RTN","PSOBORP3",237,0)
.W !!,$E(NAME,1,30)_"/"_ID,?36,RX,?54,ECMENBR,?72,RXDATE,?90,RXINFO
"RTN","PSOBORP3",238,0)
.W !,?4,$$DATTIM($P(ACTDT,".",1)),?22,$E(USER,1,20),?58,$FN(AMTBILL,"T",2),?72,RXQTY,?84,NDCNBR,?103,RXDRUG
"RTN","PSOBORP3",239,0)
.I $D(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,3)) D NCPDPRC(.PSOAUD)
"RTN","PSOBORP3",240,0)
.;
"RTN","PSOBORP3",241,0)
.;TRICARE justification
"RTN","PSOBORP3",242,0)
.I $E(IOST,1,2)="C-" D
"RTN","PSOBORP3",243,0)
..I $L(TRIJUST)>125 W !,?4,$E(TRIJUST,1,125)_"..."
"RTN","PSOBORP3",244,0)
..I $L(TRIJUST)<125 W !,?4,TRIJUST
"RTN","PSOBORP3",245,0)
;
"RTN","PSOBORP3",246,0)
;if Excel format is selected
"RTN","PSOBORP3",247,0)
I PSOEXCEL D
"RTN","PSOBORP3",248,0)
.N REJIEN,FILE,FIELD,NCPDIEN,RJCDS,REJEXP
"RTN","PSOBORP3",249,0)
.S REJIEN=0,FILE=9002313.93,FIELD=.02,RJCDS="",REJEXP=""
"RTN","PSOBORP3",250,0)
.I $D(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,3)) F S REJIEN=$O(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,3,REJIEN)) Q:'REJIEN D
"RTN","PSOBORP3",251,0)
..S NCPDIEN=$G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,3,REJIEN))
"RTN","PSOBORP3",252,0)
..S RJCDS=$S($G(RJCDS)="":NCPDIEN,1:RJCDS_","_NCPDIEN)
"RTN","PSOBORP3",253,0)
.I RJCDS'="",$P(RJCDS,":",1)'="eT",$P(RJCDS,":",1)'="eC" S REJEXP=$$GET1^DIQ(FILE,+$P(RJCDS,",",1),FIELD)
"RTN","PSOBORP3",254,0)
.I RJCDS'="",$P(RJCDS,":",1)="eT" S REJEXP="TRICARE-DRUG NON BILLABLE"
"RTN","PSOBORP3",255,0)
.I RJCDS'="",$P(RJCDS,":",1)="eC" S REJEXP="CHAMPVA-DRUG NON BILLABLE"
"RTN","PSOBORP3",256,0)
.W !,DIVISION_"^"_PTELIG_"^"_RTYPE_"^"_PROVIDER_"^"_$E(NAME,1,30)_"^"_ID_"^"_RX_"^"_ECMENBR_"^"_RXDATE_"^"_RXINFO_"^"
"RTN","PSOBORP3",257,0)
.W $$DATTIM($P(ACTDT,".",1))_"^"_$E(USER,1,20)_"^"_$FN(AMTBILL,"T",2)_"^"_RXQTY_"^"_NDCNBR_"^"_RXDRUG_"^"_RJCDS_"^"_$P(RJCDS,",",1)_"^"_REJEXP_"^"_TRIJUST
"RTN","PSOBORP3",258,0)
;
"RTN","PSOBORP3",259,0)
Q
"RTN","PSOBORP3",260,0)
;
"RTN","PSOBORP3",261,0)
NCPDPRC(PSOAUD) ;
"RTN","PSOBORP3",262,0)
;writes the NCPD reject code
"RTN","PSOBORP3",263,0)
;
"RTN","PSOBORP3",264,0)
N REJIEN,FILE,FIELD,NCPDCD,NCPDIEN,REJTXT
"RTN","PSOBORP3",265,0)
S REJIEN=0,FILE=9002313.93,FIELD=.02
"RTN","PSOBORP3",266,0)
F S REJIEN=$O(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,3,REJIEN)) Q:'REJIEN D
"RTN","PSOBORP3",267,0)
.S NCPDCD=$G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,3,REJIEN))
"RTN","PSOBORP3",268,0)
.I NCPDCD'="eT",NCPDCD'="eC" D
"RTN","PSOBORP3",269,0)
..S NCPDIEN=$O(^BPSF(FILE,"B",NCPDCD,"")),REJTXT=$$GET1^DIQ(FILE,NCPDIEN,FIELD)
"RTN","PSOBORP3",270,0)
.I NCPDCD="eT" S REJTXT="TRICARE-DRUG NON BILLABLE"
"RTN","PSOBORP3",271,0)
.I NCPDCD="eC" S REJTXT="CHAMPVA-DRUG NON BILLABLE"
"RTN","PSOBORP3",272,0)
.I 'PSOEXCEL W !,?4,NCPDCD_":"_REJTXT
"RTN","PSOBORP3",273,0)
.I PSOEXCEL W !,NCPDCD_":"_REJTXT
"RTN","PSOBORP3",274,0)
;
"RTN","PSOBORP3",275,0)
Q
"RTN","PSOBORP3",276,0)
;
"RTN","PSOBORP3",277,0)
RXINFO(RXNBR) ;
"RTN","PSOBORP3",278,0)
;this will return the data needed for the RX INFO on the Audit Report.
"RTN","PSOBORP3",279,0)
;
"RTN","PSOBORP3",280,0)
;
"RTN","PSOBORP3",281,0)
N RFL,CMOP,RXSTATUS,FILLOC,BILLTYPE,RELDATE,RELSTATUS
"RTN","PSOBORP3",282,0)
S RFL=$$LSTRFL^PSOBPSU1(RXNBR)
"RTN","PSOBORP3",283,0)
S BILLTYPE="**"
"RTN","PSOBORP3",284,0)
S FILLOC=$$MWC^PSOBPSU2(RXNBR,RFL)
"RTN","PSOBORP3",285,0)
S RXSTATUS=$$GET1^DIQ(52,RXNBR,100,"I")
"RTN","PSOBORP3",286,0)
S RXSTATUS=$$RXSTANAM(RXSTATUS)
"RTN","PSOBORP3",287,0)
S RELDATE=$$RXRLDT^PSOBPSUT(RXNBR,RFL)
"RTN","PSOBORP3",288,0)
S RELSTATUS=$S(RELDATE'="":"R",1:"N")
"RTN","PSOBORP3",289,0)
I 'PSOEXCEL Q FILLOC_" "_BILLTYPE_" "_RXSTATUS_"/"_RELSTATUS
"RTN","PSOBORP3",290,0)
I PSOEXCEL Q FILLOC_"^"_RXSTATUS_"/"_RELSTATUS
"RTN","PSOBORP3",291,0)
;
"RTN","PSOBORP3",292,0)
RXSTANAM(BPRXSTAT) ;*/
"RTN","PSOBORP3",293,0)
Q:BPRXSTAT=0 "AC" ; ACTIVE;
"RTN","PSOBORP3",294,0)
Q:BPRXSTAT=1 "NV" ; NON-VERIFIED;
"RTN","PSOBORP3",295,0)
Q:BPRXSTAT=3 "HL" ; HOLD;
"RTN","PSOBORP3",296,0)
Q:BPRXSTAT=5 "SU" ; SUSPENDED;
"RTN","PSOBORP3",297,0)
Q:BPRXSTAT=11 "EX" ; EXPIRED;
"RTN","PSOBORP3",298,0)
Q:BPRXSTAT=12 "DS" ; DISCONTINUED;
"RTN","PSOBORP3",299,0)
Q:BPRXSTAT=13 "DL" ; DELETED;
"RTN","PSOBORP3",300,0)
Q:BPRXSTAT=14 "DS" ; DISCONTINUED BY PROVIDER;
"RTN","PSOBORP3",301,0)
Q:BPRXSTAT=15 "DS" ; DISCONTINUED (EDIT);
"RTN","PSOBORP3",302,0)
Q:BPRXSTAT=16 "HL" ; PROVIDER HOLD;
"RTN","PSOBORP3",303,0)
Q:BPRXSTAT=-1 "??"
"RTN","PSOBORP3",304,0)
Q ""
"RTN","PSOBORP3",305,0)
;
"RTN","PSOBORP3",306,0)
;
"RTN","PSOBORP3",307,0)
TCSSUMP(SUBTOT,RXCNT,TCTYPE,PROVIDER,PHARMCST) ;print the summary
"RTN","PSOBORP3",308,0)
;
"RTN","PSOBORP3",309,0)
I TCTYPE="TRICARE INPATIENT"!(TCTYPE="CHAMPVA INPATIENT") Q
"RTN","PSOBORP3",310,0)
S RJHDR=$E(STAR,1,30)_$E(SPACE,1,3)_TCTYPE_$E(SPACE,1,3)_$E(STAR,1,(57-$L(TCTYPE)))
"RTN","PSOBORP3",311,0)
;
"RTN","PSOBORP3",312,0)
;subtotals by provider
"RTN","PSOBORP3",313,0)
W !!,?7,$S(PSOSEL("TOTALS BY")="P":"PROVIDER: ",1:"PHARMACIST: "),PROVIDER,?44,$E(DASH,1,13)
"RTN","PSOBORP3",314,0)
W !,?7,"SUB-TOTALS",?51,SUBTOT
"RTN","PSOBORP3",315,0)
W !,?7,"RX COUNT",?51,RXCNT
"RTN","PSOBORP3",316,0)
W !,?7,"MEAN",?51,$FN(SUBTOT/RXCNT,"T",2),!
"RTN","PSOBORP3",317,0)
;
"RTN","PSOBORP3",318,0)
Q
"RTN","PSOBORP3",319,0)
;
"RTN","PSOBORP3",320,0)
TCHDR(TCTYPE) ;print report header
"RTN","PSOBORP3",321,0)
;
"RTN","PSOBORP3",322,0)
S (SUBTOT,RXCNT)=""
"RTN","PSOBORP3",323,0)
I 'PSOEXCEL D Q
"RTN","PSOBORP3",324,0)
.S RJHDR=$E(STAR,1,30)_$E(SPACE,1,3)_TCTYPE_$E(SPACE,1,3)_$E(STAR,1,(57-$L(TCTYPE)))
"RTN","PSOBORP3",325,0)
.W !!,RJHDR
"RTN","PSOBORP3",326,0)
;
"RTN","PSOBORP3",327,0)
;
"RTN","PSOBORP3",328,0)
Q
"RTN","PSOBORP3",329,0)
;
"RTN","PSOBORP3",330,0)
HDR ;
"RTN","PSOBORP3",331,0)
S HDR1="TRICARE-CHAMPVA OVERRIDE AUDIT REPORT - "_DETSUM_" Print Date: "_PSONOW
"RTN","PSOBORP3",332,0)
S HDR2="DIVISION(S): "_$$DIVISION()
"RTN","PSOBORP3",333,0)
S HDR3="ELIGIBILITY: "_$$ELIG()
"RTN","PSOBORP3",334,0)
S HDR4="TC TYPES: "_$$HDR4(.PSOSEL)
"RTN","PSOBORP3",335,0)
S HDR5="ALL PRESCRIPTIONS BY AUDIT DATE: From "_BEGDT_" through "_ENDDT
"RTN","PSOBORP3",336,0)
I PSOSEL("SUM_DETAIL")="D" D
"RTN","PSOBORP3",337,0)
.S HDR6="BENEFICIARY NAME/ID"_$E(SPACE,1,17)_"RX#"_$E(SPACE,1,15)_"REF/ECME#"_$E(SPACE,1,9)_"RX DATE"_$E(SPACE,1,11)_"RX INFO"
"RTN","PSOBORP3",338,0)
.S HDR7=$E(SPACE,1,4)_"ACTION DATE"_$E(SPACE,1,8)_"USER NAME"_$E(SPACE,1,26)_"$BILLED "_$E(SPACE,1,6)_"QTY"_$E(SPACE,1,9)_"NDC#"_$E(SPACE,1,15)_"DRUG"
"RTN","PSOBORP3",339,0)
Q
"RTN","PSOBORP3",340,0)
;
"RTN","PSOBORP3",341,0)
HDR4(PSOSEL) ;
"RTN","PSOBORP3",342,0)
;
"RTN","PSOBORP3",343,0)
N TCTYPE,RCODE
"RTN","PSOBORP3",344,0)
S (RCODE,TCTYPE)=""
"RTN","PSOBORP3",345,0)
F S TCTYPE=$O(PSOSEL("REJECT CODES",TCTYPE)) Q:TCTYPE="" D
"RTN","PSOBORP3",346,0)
.I $G(RCODE)="" S RCODE=PSOSEL("REJECT CODES",TCTYPE)
"RTN","PSOBORP3",347,0)
.E S RCODE=RCODE_", "_PSOSEL("REJECT CODES",TCTYPE)
"RTN","PSOBORP3",348,0)
;
"RTN","PSOBORP3",349,0)
Q RCODE
"RTN","PSOBORP3",350,0)
;
"RTN","PSOBORP3",351,0)
;
"RTN","PSOBORP3",352,0)
DIVISION() ;list of divisions for header
"RTN","PSOBORP3",353,0)
;
"RTN","PSOBORP3",354,0)
N DIV,DIVISION
"RTN","PSOBORP3",355,0)
S (DIVISION,DIV)=""
"RTN","PSOBORP3",356,0)
I PSOSEL("DIVISION")="A" Q "ALL"
"RTN","PSOBORP3",357,0)
F S DIV=$O(PSOSEL("DIVISION",DIV)) Q:DIV="" D
"RTN","PSOBORP3",358,0)
.I DIVISION="" S DIVISION=$P(PSOSEL("DIVISION",DIV),"^",2) Q
"RTN","PSOBORP3",359,0)
.S DIVISION=DIVISION_$P(PSOSEL("DIVISION",DIV),"^",2)
"RTN","PSOBORP3",360,0)
Q DIVISION
"RTN","PSOBORP3",361,0)
;
"RTN","PSOBORP3",362,0)
;
"RTN","PSOBORP3",363,0)
REJECTS() ;list the reject types for the header
"RTN","PSOBORP3",364,0)
;
"RTN","PSOBORP3",365,0)
N REJ,REJECTS
"RTN","PSOBORP3",366,0)
S (REJECTS,REJ)=""
"RTN","PSOBORP3",367,0)
F S REJ=$O(PSOSEL("REJECT CODES",REJ)) Q:REJ="" D
"RTN","PSOBORP3",368,0)
.I REJECTS="" S REJECTS=$S(REJ="I":"INPATIENT",REJ="N":"NON-BILLABLE",REJ="R":"REJECT OVERRIDE",REJ="P":"PARTIAL FILL",1:"ALL")
"RTN","PSOBORP3",369,0)
.E S REJECTS=REJECTS_" "_$S(REJ="I":"INPATIENT",REJ="N":"NON-BILLABLE",REJ="R":"REJECT OVERRIDE",REJ="P":"PARTIAL FILL",1:"ALL")
"RTN","PSOBORP3",370,0)
;
"RTN","PSOBORP3",371,0)
Q REJECTS
"RTN","PSOBORP3",372,0)
;
"RTN","PSOBORP3",373,0)
;
"RTN","PSOBORP3",374,0)
INIT ;
"RTN","PSOBORP3",375,0)
;
"RTN","PSOBORP3",376,0)
N %,Y
"RTN","PSOBORP3",377,0)
D NOW^%DTC S Y=% D DD^%DT S PSONOW=Y
"RTN","PSOBORP3",378,0)
S $P(SPACE," ",150)=""
"RTN","PSOBORP3",379,0)
S $P(DASH,"-",150)=""
"RTN","PSOBORP3",380,0)
S $P(EQUAL,"=",150)=""
"RTN","PSOBORP3",381,0)
S $P(STAR,"*",150)=""
"RTN","PSOBORP3",382,0)
S PAGE="PAGE: "
"RTN","PSOBORP3",383,0)
S DETSUM=$S(PSOSEL("SUM_DETAIL")="S":"SUMMARY",1:"DETAIL")
"RTN","PSOBORP3",384,0)
S BEGDT=$$DATTIM(PSOSEL("BEGIN DATE"))
"RTN","PSOBORP3",385,0)
S ENDDT=$$DATTIM(PSOSEL("END DATE"))
"RTN","PSOBORP3",386,0)
S PSOEXCEL=$G(PSOSEL("EXCEL"))
"RTN","PSOBORP3",387,0)
K SUBTOTAL,MEAN,SUBTOT,DIVISION,PROVIDER,TCTYPE,TCTYPE,RXCNT
"RTN","PSOBORP3",388,0)
;
"RTN","PSOBORP3",389,0)
Q
"RTN","PSOBORP3",390,0)
;
"RTN","PSOBORP3",391,0)
;Convert FM date or date.time to displayable (mm/dd/yy HH:MM) format
"RTN","PSOBORP3",392,0)
;
"RTN","PSOBORP3",393,0)
DATTIM(X) ;
"RTN","PSOBORP3",394,0)
N DATE,BPT,BPM,BPH,BPAP
"RTN","PSOBORP3",395,0)
S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")
"RTN","PSOBORP3",396,0)
S BPT=$P(X,".",2) S:$L(BPT)<4 BPT=BPT_$E("0000",1,4-$L(BPT))
"RTN","PSOBORP3",397,0)
S BPH=$E(BPT,1,2),BPM=$E(BPT,3,4)
"RTN","PSOBORP3",398,0)
S BPAP="AM" I BPH>12 S BPH=BPH-12,BPAP="PM" S:$L(BPH)<2 BPH="0"_BPH
"RTN","PSOBORP3",399,0)
I BPT S:'BPH BPH=12 S DATE=DATE_" "_BPH_":"_BPM_BPAP
"RTN","PSOBORP3",400,0)
Q $G(DATE)
"RTN","PSOBORP3",401,0)
;
"RTN","PSOBORP3",402,0)
;
"RTN","PSOBORP3",403,0)
ELIG() ; eligibility for header
"RTN","PSOBORP3",404,0)
Q $S(PSOSEL("ELIG_TYPE")="T":"TRICARE",PSOSEL("ELIG_TYPE")="C":"CHAMPVA",1:"ALL")
"RTN","PSOBORP3",405,0)
;
"RTN","PSOREJP2")
0^5^B228344655
"RTN","PSOREJP2",1,0)
PSOREJP2 ;BIRM/MFR - Third Party Rejects View/Process ;04/28/05
"RTN","PSOREJP2",2,0)
;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289,358,385,403,421,427,448,482,512,528**;DEC 1997;Build 8
"RTN","PSOREJP2",3,0)
;Reference to ^PSSLOCK supported by IA #2789
"RTN","PSOREJP2",4,0)
;Reference to GETDAT^BPSBUTL supported by IA #4719
"RTN","PSOREJP2",5,0)
;Reference to ^PS(55 supported by IA #2228
"RTN","PSOREJP2",6,0)
;Reference to ^DIC(36 supported by ICR #6142
"RTN","PSOREJP2",7,0)
;
"RTN","PSOREJP2",8,0)
N PSORJSRT,PSOPTFLT,PSODRFLT,PSORXFLT,PSOBYFLD,PSOSTFLT,DIR,DIRUT,DUOUT,DTOUT
"RTN","PSOREJP2",9,0)
N PSOINFLT,PSODTRNG,PSOINGRP,PSOTRITG,PSOCVATG
"RTN","PSOREJP2",10,0)
S PSORJASC=1,PSOINGRP=0,PSOTRITG=1,PSOCVATG=1
"RTN","PSOREJP2",11,0)
;
"RTN","PSOREJP2",12,0)
; - Division/Site selection
"RTN","PSOREJP2",13,0)
D SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$G(PSOSITE),.01)) I $G(PSOREJST)="^" G EXIT
"RTN","PSOREJP2",14,0)
;
"RTN","PSOREJP2",15,0)
; - Date range selection
"RTN","PSOREJP2",16,0)
W ! S PSODTRNG=$$DTRNG("T-90","T") I PSODTRNG="^" G EXIT
"RTN","PSOREJP2",17,0)
;
"RTN","PSOREJP2",18,0)
SEL ; - Field Selection (Patient/Drug/Rx)
"RTN","PSOREJP2",19,0)
S DIR(0)="S^P:PATIENT;D:DRUG;R:Rx;I:INSURANCE",DIR("B")="P"
"RTN","PSOREJP2",20,0)
S DIR("A")="By (P)atient, (D)rug, (R)x or (I)nsurance" D ^DIR I $D(DIRUT) G EXIT
"RTN","PSOREJP2",21,0)
S PSOBYFLD=Y,DIR("B")=""
"RTN","PSOREJP2",22,0)
;
"RTN","PSOREJP2",23,0)
I PSOBYFLD="P" D I $G(PSOPTFLT)="^" G SEL
"RTN","PSOREJP2",24,0)
. S (PSODRFLT,PSORXFLT,PSOINFLT)="ALL",PSORJSRT="DR"
"RTN","PSOREJP2",25,0)
. D SEL^PSOREJU1("PATIENT","^DPT(",.PSOPTFLT)
"RTN","PSOREJP2",26,0)
;
"RTN","PSOREJP2",27,0)
I PSOBYFLD="D" D I $G(PSODRFLT)="^" G SEL
"RTN","PSOREJP2",28,0)
. S (PSOPTFLT,PSORXFLT,PSOINFLT)="ALL",PSORJSRT="PA"
"RTN","PSOREJP2",29,0)
. D SEL^PSOREJU1("DRUG","^PSDRUG(",.PSODRFLT)
"RTN","PSOREJP2",30,0)
;
"RTN","PSOREJP2",31,0)
I PSOBYFLD="R" D I $D(DIRUT)!'$G(PSORXFLT) G SEL
"RTN","PSOREJP2",32,0)
. S (PSOPTFLT,PSODRFLT,PSOINFLT)="ALL",PSORJSRT="PA"
"RTN","PSOREJP2",33,0)
. N DIR,DIRUT,PSODRUG,PSOQUIT,PSORX,PSORXD,RXIEN,X
"RTN","PSOREJP2",34,0)
. K PSOSTFLT,PSORXFLT
"RTN","PSOREJP2",35,0)
. S DIR(0)="FAO^1:30"
"RTN","PSOREJP2",36,0)
. S DIR("A")=" PRESCRIPTION: "
"RTN","PSOREJP2",37,0)
. S DIR("?",1)=" A prescription number or ECME number may be entered. To look-up a"
"RTN","PSOREJP2",38,0)
. S DIR("?",2)=" prescription by the ECME number, please enter ""E."" followed by the ECME"
"RTN","PSOREJP2",39,0)
. S DIR("?")=" number with or without any leading zeros."
"RTN","PSOREJP2",40,0)
. ;
"RTN","PSOREJP2",41,0)
. W ! D ^DIR I X=""!$D(DIRUT) Q
"RTN","PSOREJP2",42,0)
. S X=$$UP^XLFSTR(X),PSOQUIT=0
"RTN","PSOREJP2",43,0)
. ;
"RTN","PSOREJP2",44,0)
. ; Prescription Number
"RTN","PSOREJP2",45,0)
. I $E(X,1,2)'="E." S RXIEN=+$$RXLKP^PSOSPML4(X) I RXIEN<0 Q
"RTN","PSOREJP2",46,0)
. ;
"RTN","PSOREJP2",47,0)
. ; ECME Number
"RTN","PSOREJP2",48,0)
. I $E(X,1,2)="E." D I PSOQUIT Q
"RTN","PSOREJP2",49,0)
. . S RXIEN=+$$RXNUM^PSOBPSU2($E(X,3,$L(X)))
"RTN","PSOREJP2",50,0)
. . I RXIEN<0 W " ??" S PSOQUIT=1 Q
"RTN","PSOREJP2",51,0)
. . S DIC=52,DR=".01;6",DA=RXIEN,DIQ="PSORXD",DIQ(0)="E"
"RTN","PSOREJP2",52,0)
. . D DIQ^PSODI(52,DIC,DR,DA,.DIQ)
"RTN","PSOREJP2",53,0)
. . S PSORX=$G(PSORXD(52,DA,.01,"E"))
"RTN","PSOREJP2",54,0)
. . S PSODRUG=$G(PSORXD(52,DA,6,"E"))
"RTN","PSOREJP2",55,0)
. . W ?31,PSORX_" "_PSODRUG
"RTN","PSOREJP2",56,0)
. ;
"RTN","PSOREJP2",57,0)
. I '$O(^PSRX(RXIEN,"REJ",0)) D Q
"RTN","PSOREJP2",58,0)
. . W !?40,"Prescription does not have rejects!",$C(7)
"RTN","PSOREJP2",59,0)
. ;
"RTN","PSOREJP2",60,0)
. S PSORXFLT=RXIEN
"RTN","PSOREJP2",61,0)
;
"RTN","PSOREJP2",62,0)
; Insurance Company Lookup - ICR 6142
"RTN","PSOREJP2",63,0)
I PSOBYFLD="I" D I $G(PSOINFLT)="^" G SEL
"RTN","PSOREJP2",64,0)
. S (PSOPTFLT,PSODRFLT,PSORXFLT)="ALL",PSORJSRT="PA"
"RTN","PSOREJP2",65,0)
. D SEL^PSOREJU1("INSURANCE","^DIC(36,",.PSOINFLT)
"RTN","PSOREJP2",66,0)
;
"RTN","PSOREJP2",67,0)
; - Status Selection (UNRESOLVED or RESOLVED)
"RTN","PSOREJP2",68,0)
I $G(PSOSTFLT)="" D I $D(DIRUT) G EXIT
"RTN","PSOREJP2",69,0)
. S DIR(0)="S^U:UNRESOLVED;R:RESOLVED;B:BOTH",DIR("B")="B"
"RTN","PSOREJP2",70,0)
. S DIR("A")="(U)NRESOLVED, (R)RESOLVED or (B)OTH REJECT statuses" D ^DIR
"RTN","PSOREJP2",71,0)
. S PSOSTFLT=Y
"RTN","PSOREJP2",72,0)
;
"RTN","PSOREJP2",73,0)
D LST^PSOREJP0("VP")
"RTN","PSOREJP2",74,0)
;
"RTN","PSOREJP2",75,0)
EXIT Q
"RTN","PSOREJP2",76,0)
;
"RTN","PSOREJP2",77,0)
CLO ; - Ignore a REJECT hidden action
"RTN","PSOREJP2",78,0)
N PSOTRIC,X,PSOETEC,PSOIT
"RTN","PSOREJP2",79,0)
;
"RTN","PSOREJP2",80,0)
; ESG - PSO*7*448 - Bug fix, should pull FILL from sub-file 52.25.
"RTN","PSOREJP2",81,0)
I '$D(FILL) S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
"RTN","PSOREJP2",82,0)
S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
"RTN","PSOREJP2",83,0)
;
"RTN","PSOREJP2",84,0)
;reference to ^XUSEC( supported by IA 10076
"RTN","PSOREJP2",85,0)
;bld, PSO*7*358
"RTN","PSOREJP2",86,0)
I PSOTRIC,'$D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S VALMSG="Action Requires <PSO TRICARE/CHAMPVA> security key",VALMBCK="R" Q
"RTN","PSOREJP2",87,0)
;if TRICARE or CHAMPVA and user has security key, prompt to continue or not
"RTN","PSOREJP2",88,0)
;
"RTN","PSOREJP2",89,0)
; Check for Ignore Threshold
"RTN","PSOREJP2",90,0)
S PSOIT=$$IGNORE^PSOREJU1(RX,FILL)
"RTN","PSOREJP2",91,0)
I $P(PSOIT,"^")=0 D Q
"RTN","PSOREJP2",92,0)
. S VALMBCK="R"
"RTN","PSOREJP2",93,0)
. I $P(PSOIT,"^",2)'="" D
"RTN","PSOREJP2",94,0)
. . W !!,"Gross Amount Due is $"_$P(PSOIT,"^",2)_". IGNORE requires EPHARMACY SITE MANAGER key."
"RTN","PSOREJP2",95,0)
. . D WAIT^VALM1
"RTN","PSOREJP2",96,0)
;
"RTN","PSOREJP2",97,0)
I PSOTRIC,'$$CONT^PSOREJU1() S VALMBCK="R" Q
"RTN","PSOREJP2",98,0)
;
"RTN","PSOREJP2",99,0)
I $$CLOSED^PSOREJP1(RX,REJ) D Q
"RTN","PSOREJP2",100,0)
. S VALMSG="This Reject is marked resolved!",VALMBCK="R"
"RTN","PSOREJP2",101,0)
N DIR,COM
"RTN","PSOREJP2",102,0)
D FULL^VALM1
"RTN","PSOREJP2",103,0)
I '$$SIG^PSOREJU1() S VALMBCK="R" Q
"RTN","PSOREJP2",104,0)
W !
"RTN","PSOREJP2",105,0)
S:PSOTRIC COM=$$TCOM^PSOREJP3(RX,FILL) S:'PSOTRIC COM=$$COM^PSOREJU1()
"RTN","PSOREJP2",106,0)
I COM="^" S VALMBCK="R" Q
"RTN","PSOREJP2",107,0)
W !
"RTN","PSOREJP2",108,0)
S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="NO"
"RTN","PSOREJP2",109,0)
S DIR("A",1)=" When you confirm this REJECT will be marked RESOLVED."
"RTN","PSOREJP2",110,0)
S DIR("A",2)=" "
"RTN","PSOREJP2",111,0)
D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
"RTN","PSOREJP2",112,0)
W ?40,"[Closing..." D CLOSE^PSOREJUT(RX,FILL,REJ,DUZ,6,COM,"","","","","",1) W "OK]",!,$C(7) H 1
"RTN","PSOREJP2",113,0)
I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
"RTN","PSOREJP2",114,0)
;
"RTN","PSOREJP2",115,0)
I $$PTLBL(RX,FILL) D PRINT^PSOREJP3(RX,FILL)
"RTN","PSOREJP2",116,0)
I PSOTRIC D
"RTN","PSOREJP2",117,0)
.S PSOETEC=$$PSOETEC^PSOREJP5(RX,FILL)
"RTN","PSOREJP2",118,0)
.D AUDIT^PSOTRI(RX,FILL,,COM,$S(PSOETEC:"N",1:"R"),$S(PSOTRIC=1:"T",PSOTRIC=2:"C",1:""))
"RTN","PSOREJP2",119,0)
;
"RTN","PSOREJP2",120,0)
Q
"RTN","PSOREJP2",121,0)
;
"RTN","PSOREJP2",122,0)
OPN ; - Re-open a Closed/Resolved Reject
"RTN","PSOREJP2",123,0)
I '$$CLOSED^PSOREJP1(RX,REJ) D Q
"RTN","PSOREJP2",124,0)
. S VALMSG="This Reject is NOT marked resolved!",VALMBCK="R"
"RTN","PSOREJP2",125,0)
;cnf, PSO*7*358, check for discontinued and not released
"RTN","PSOREJP2",126,0)
; 12 - DISCONTINUED
"RTN","PSOREJP2",127,0)
; 14 - DISCONTINUED BY PROVIDER
"RTN","PSOREJP2",128,0)
; 15 - DISCONTINUED (EDIT)
"RTN","PSOREJP2",129,0)
N DCSTAT,PSOREL
"RTN","PSOREJP2",130,0)
S DCSTAT=$$GET1^DIQ(52,RX,100,"I")
"RTN","PSOREJP2",131,0)
S PSOREL=0 D
"RTN","PSOREJP2",132,0)
. I 'FILL S PSOREL=+$$GET1^DIQ(52,RX,31,"I")
"RTN","PSOREJP2",133,0)
. I FILL S PSOREL=+$$GET1^DIQ(52.1,FILL_","_RX,17,"I")
"RTN","PSOREJP2",134,0)
I 'PSOREL,"/12/14/15/"[("/"_DCSTAT_"/") S VALMSG="Discontinued Rx has not been released.",VALMBCK="R" Q
"RTN","PSOREJP2",135,0)
N DIR,COM,REJDATA,NEWDATA,X,REOPEN
"RTN","PSOREJP2",136,0)
D FULL^VALM1
"RTN","PSOREJP2",137,0)
I '$$SIG^PSOREJU1() S VALMBCK="R" Q
"RTN","PSOREJP2",138,0)
W !
"RTN","PSOREJP2",139,0)
S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="NO"
"RTN","PSOREJP2",140,0)
S DIR("A",1)=" When you confirm this REJECT will be marked UNRESOLVED."
"RTN","PSOREJP2",141,0)
S DIR("A",2)=" "
"RTN","PSOREJP2",142,0)
D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
"RTN","PSOREJP2",143,0)
;
"RTN","PSOREJP2",144,0)
W ?40,"[Re-opening..."
"RTN","PSOREJP2",145,0)
K REJDATA D GET^PSOREJU2(RX,FILL,.REJDATA,REJ,1) D SETOPN^PSOREJU2(RX,REJ)
"RTN","PSOREJP2",146,0)
K NEWDATA M NEWDATA=REJDATA(REJ) S NEWDATA("PHARMACIST")=DUZ
"RTN","PSOREJP2",147,0)
S REOPEN=1 D SAVE^PSOREJUT(RX,FILL,.NEWDATA,REOPEN)
"RTN","PSOREJP2",148,0)
I $G(NEWDATA("REJECT IEN")),$D(REJDATA(REJ,"COMMENTS")) D
"RTN","PSOREJP2",149,0)
. S COM=0 F S COM=$O(REJDATA(REJ,"COMMENTS",COM)) Q:'COM D
"RTN","PSOREJP2",150,0)
. . S X(1)=REJDATA(REJ,"COMMENTS",COM,"COMMENTS")
"RTN","PSOREJP2",151,0)
. . S X(2)=REJDATA(REJ,"COMMENTS",COM,"DATE/TIME")
"RTN","PSOREJP2",152,0)
. . S X(3)=REJDATA(REJ,"COMMENTS",COM,"USER")
"RTN","PSOREJP2",153,0)
. . D SAVECOM^PSOREJP3(RX,NEWDATA("REJECT IEN"),X(1),X(2),X(3))
"RTN","PSOREJP2",154,0)
D RETRXF^PSOREJU2(RX,FILL,0)
"RTN","PSOREJP2",155,0)
W "OK]",!,$C(7) H 1
"RTN","PSOREJP2",156,0)
S CHANGE=1
"RTN","PSOREJP2",157,0)
Q
"RTN","PSOREJP2",158,0)
;
"RTN","PSOREJP2",159,0)
SDC ; - Suspense Date Calculation
"RTN","PSOREJP2",160,0)
D CHG(1)
"RTN","PSOREJP2",161,0)
Q
"RTN","PSOREJP2",162,0)
;
"RTN","PSOREJP2",163,0)
CSD ;CSD - Change Suspense Date action entry point
"RTN","PSOREJP2",164,0)
D CHG(0)
"RTN","PSOREJP2",165,0)
Q
"RTN","PSOREJP2",166,0)
;
"RTN","PSOREJP2",167,0)
CHG(SDC) ; - Change Suspense Date action
"RTN","PSOREJP2",168,0)
;Local:
"RTN","PSOREJP2",169,0)
; SDC - indicates if the suspense date is being manually changed or calculated.
"RTN","PSOREJP2",170,0)
; RX - RX IEN
"RTN","PSOREJP2",171,0)
; REJ - Reject indicator
"RTN","PSOREJP2",172,0)
;
"RTN","PSOREJP2",173,0)
I '$G(SDC) S SDC=0
"RTN","PSOREJP2",174,0)
I $$CLOSED^PSOREJP1(RX,REJ) D Q
"RTN","PSOREJP2",175,0)
. S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7)
"RTN","PSOREJP2",176,0)
;
"RTN","PSOREJP2",177,0)
N SUSDT,PSOMSG,Y,SUSRX,%DT,DA,DIE,DR,ISSDT,EXPDT,PSOMSG,CUTDT,FILDT,RFL,COB
"RTN","PSOREJP2",178,0)
;
"RTN","PSOREJP2",179,0)
S RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5),SUSDT=$$RXSUDT^PSOBPSUT(RX,RFL)
"RTN","PSOREJP2",180,0)
I RFL>0 S FILDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I")
"RTN","PSOREJP2",181,0)
E S FILDT=$$GET1^DIQ(52,RX,22,"I")
"RTN","PSOREJP2",182,0)
I SUSDT="" S VALMSG="Prescription is not suspended!",VALMBCK="R" W $C(7) Q
"RTN","PSOREJP2",183,0)
I $$RXRLDT^PSOBPSUT(RX,RFL) S VALMSG="Prescription has been released already!",VALMBCK="R" W $C(7) Q
"RTN","PSOREJP2",184,0)
;cnf, PSO*7*358, add PSOET logic for TRICARE/CHAMPVA non-billable
"RTN","PSOREJP2",185,0)
S PSOET=$$PSOET^PSOREJP3(RX,RFL)
"RTN","PSOREJP2",186,0)
I PSOET S VALMSG=$S(SDC=1:"SDC",1:"CSD")_" not allowed for "_$$ELIGDISP^PSOREJP1(RX,RFL)_" Non-Billable claim.",VALMBCK="R" Q
"RTN","PSOREJP2",187,0)
;
"RTN","PSOREJP2",188,0)
D PSOL^PSSLOCK(RX) I '$G(PSOMSG) S VALMSG=$P(PSOMSG,"^",2),VALMBCK="R" W $C(7) Q
"RTN","PSOREJP2",189,0)
;
"RTN","PSOREJP2",190,0)
S ISSDT=$$GET1^DIQ(52,RX,1,"I"),EXPDT=$$GET1^DIQ(52,RX,26,"I")
"RTN","PSOREJP2",191,0)
S SUSRX=$O(^PS(52.5,"B",RX,0))
"RTN","PSOREJP2",192,0)
;
"RTN","PSOREJP2",193,0)
D FULL^VALM1
"RTN","PSOREJP2",194,0)
I SDC D I SUSDT=0 D PSOUL^PSSLOCK(RX) S VALMBCK="R" Q
"RTN","PSOREJP2",195,0)
. S COB=$$GET1^DIQ(52.25,REJ_","_RX,27,"I")
"RTN","PSOREJP2",196,0)
. I 'COB S COB=1
"RTN","PSOREJP2",197,0)
. S SUSDT=$$CALCSD(RX,RFL,COB)
"RTN","PSOREJP2",198,0)
;
"RTN","PSOREJP2",199,0)
SUDT ; Asks for the new Suspense Date
"RTN","PSOREJP2",200,0)
N X1,X2
"RTN","PSOREJP2",201,0)
S X1=FILDT,X2=89 D C^%DTC S CUTDT=X
"RTN","PSOREJP2",202,0)
I SDC,SUSDT,SUSDT<DT W !,*7," **CALCULATED SUSPENSE DATE IS IN THE PAST: ",$$FMTE^XLFDT(SUSDT),"**" S SUSDT=""
"RTN","PSOREJP2",203,0)
E S %DT("B")=$$FMTE^XLFDT(SUSDT)
"RTN","PSOREJP2",204,0)
S %DT="EA",%DT("A")=$S(SDC:"NEW ",1:"")_"SUSPENSE DATE: "
"RTN","PSOREJP2",205,0)
W ! D ^%DT I Y<0!($D(DTOUT)) D PSOUL^PSSLOCK(RX) S VALMBCK="R" I (SDC) W !,"ACTION NOT TAKEN!" Q
"RTN","PSOREJP2",206,0)
I Y<ISSDT D G SUDT
"RTN","PSOREJP2",207,0)
. W !!?5,"Suspense Date cannot be before Issue Date: ",$$FMTE^XLFDT(ISSDT),".",$C(7)
"RTN","PSOREJP2",208,0)
I Y>EXPDT D G SUDT
"RTN","PSOREJP2",209,0)
. W !!?5,"Suspense Date cannot be after Expiration Date: ",$$FMTE^XLFDT(EXPDT),".",$C(7)
"RTN","PSOREJP2",210,0)
I Y>CUTDT D G SUDT
"RTN","PSOREJP2",211,0)
. W !!?5,"Suspense Date cannot be after fill date plus 90 days: "_$$FMTE^XLFDT(CUTDT),".",$C(7)
"RTN","PSOREJP2",212,0)
S SUSDT=Y
"RTN","PSOREJP2",213,0)
;
"RTN","PSOREJP2",214,0)
N DIR,DIRUT W !
"RTN","PSOREJP2",215,0)
S DIR("A",1)=" When you confirm, this REJECT will be marked resolved. A"
"RTN","PSOREJP2",216,0)
S DIR("A",2)=" new claim will be re-submitted to the 3rd party payer"
"RTN","PSOREJP2",217,0)
I $$GET1^DIQ(52.5,SUSRX,3)="" D
"RTN","PSOREJP2",218,0)
. I SUSDT>DT D
"RTN","PSOREJP2",219,0)
. . S DIR("A",3)=" when the prescription label for this fill is printed"
"RTN","PSOREJP2",220,0)
. . S DIR("A",4)=" from suspense on "_$$FMTE^XLFDT(SUSDT)_"."
"RTN","PSOREJP2",221,0)
. . S DIR("A",5)=" "
"RTN","PSOREJP2",222,0)
. . S DIR("A",6)=" Note: THE LABEL FOR THIS PRESCRIPTION FILL WILL NOT BE"
"RTN","PSOREJP2",223,0)
. . S DIR("A",7)=" PRINTED LOCAL FROM SUSPENSE BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
"RTN","PSOREJP2",224,0)
. E D
"RTN","PSOREJP2",225,0)
. . S DIR("A",3)=" the next time local labels are printed from suspense."
"RTN","PSOREJP2",226,0)
E D
"RTN","PSOREJP2",227,0)
. I SUSDT>DT D
"RTN","PSOREJP2",228,0)
. . S DIR("A",3)=" when the prescription is transmitted to CMOP on "
"RTN","PSOREJP2",229,0)
. . S DIR("A",4)=" "_$$FMTE^XLFDT(SUSDT)_"."
"RTN","PSOREJP2",230,0)
. . S DIR("A",5)=" "
"RTN","PSOREJP2",231,0)
. . S DIR("A",6)=" Note: THIS PRESCRIPTION FILL WILL NOT BE TRANSMITTED TO"
"RTN","PSOREJP2",232,0)
. . S DIR("A",7)=" CMOP BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
"RTN","PSOREJP2",233,0)
. E D
"RTN","PSOREJP2",234,0)
. . S DIR("A",3)=" when this prescription fill is transmitted to CMOP on"
"RTN","PSOREJP2",235,0)
. . S DIR("A",4)=" the next CMOP transmission."
"RTN","PSOREJP2",236,0)
;
"RTN","PSOREJP2",237,0)
S DIR("A",$O(DIR("A",""),-1)+1)=" "
"RTN","PSOREJP2",238,0)
S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="YES"
"RTN","PSOREJP2",239,0)
D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" D PSOUL^PSSLOCK(RX) Q
"RTN","PSOREJP2",240,0)
;
"RTN","PSOREJP2",241,0)
; - Suspense/Fill Date updates
"RTN","PSOREJP2",242,0)
I SUSDT'=$$RXSUDT^PSOBPSUT(RX,RFL) D
"RTN","PSOREJP2",243,0)
. N DA,DIE,DR,PSOX,SFN,INDT,DEAD
"RTN","PSOREJP2",244,0)
. S DA=SUSRX,DIE="^PS(52.5,",DR=".02///"_SUSDT D ^DIE
"RTN","PSOREJP2",245,0)
. S SFN=SUSRX,DEAD=0,INDT=SUSDT D CHANGE^PSOSUCH1(RX,RFL)
"RTN","PSOREJP2",246,0)
;
"RTN","PSOREJP2",247,0)
; - Flagging the prescription to be re-submitted to ECME on the next CMOP/Print from Suspense
"RTN","PSOREJP2",248,0)
D RETRXF^PSOREJU2(RX,RFL,1)
"RTN","PSOREJP2",249,0)
W ?40,"[Closing..."
"RTN","PSOREJP2",250,0)
D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,8,"Fill Date changed to "_$$FMTE^XLFDT(SUSDT)_". A new claim will be re-submitted on this date.")
"RTN","PSOREJP2",251,0)
W "OK]",!,$C(7) H 1 I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
"RTN","PSOREJP2",252,0)
D PSOUL^PSSLOCK(RX)
"RTN","PSOREJP2",253,0)
Q
"RTN","PSOREJP2",254,0)
;
"RTN","PSOREJP2",255,0)
PTLBL(RX,RFL) ; Conditionally prompts user with 'Print Label?' prompt.
"RTN","PSOREJP2",256,0)
; If User responds YES to 'Print Label' value of 1 is returned.
"RTN","PSOREJP2",257,0)
; If User responds NO to 'Print Label' value of 0 is returned.
"RTN","PSOREJP2",258,0)
N CMP,LBL,PSOACT,PSOBPS,PSOTRIC,PTLBL,REPRINT
"RTN","PSOREJP2",259,0)
;
"RTN","PSOREJP2",260,0)
I $G(RFL)="" S RFL=$$LSTRFL^PSOBPSU1(RX)
"RTN","PSOREJP2",261,0)
;
"RTN","PSOREJP2",262,0)
; PSOBPS and PSOTRIC are used to check eligibility. Eligibility checking
"RTN","PSOREJP2",263,0)
; is only needed for non-billable Rxs (ie PSOBPS'="e")
"RTN","PSOREJP2",264,0)
S PSOBPS=$$ECME^PSOBPSUT(RX)
"RTN","PSOREJP2",265,0)
S PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,.PSOTRIC)
"RTN","PSOREJP2",266,0)
;
"RTN","PSOREJP2",267,0)
I $$FIND^PSOREJUT(RX,RFL) Q 0 ; Has OPEN/UNRESOLVED 3rd pary payer reject
"RTN","PSOREJP2",268,0)
I $$GET1^DIQ(52,RX,100,"I") Q 0 ; Rx status not ACTIVE
"RTN","PSOREJP2",269,0)
I $$RXRLDT^PSOBPSUT(RX,RFL),PSOBPS="e" Q 0 ; Rx Released - billable
"RTN","PSOREJP2",270,0)
I $$RXRLDT^PSOBPSUT(RX,RFL),PSOBPS'="e",'PSOTRIC Q 0 ; Rx Released - non-billable
"RTN","PSOREJP2",271,0)
;
"RTN","PSOREJP2",272,0)
; If CMOP Suspense Label printed for this Fill, don't allow reprint here
"RTN","PSOREJP2",273,0)
S PTLBL=1
"RTN","PSOREJP2",274,0)
S PSOACT=0
"RTN","PSOREJP2",275,0)
F S PSOACT=$O(^PSRX(RX,"A",PSOACT)) Q:'PSOACT D Q:'PTLBL
"RTN","PSOREJP2",276,0)
. I +$$GET1^DIQ(52.3,PSOACT_","_RX,.04,"I")'=RFL Q
"RTN","PSOREJP2",277,0)
. I $$GET1^DIQ(52.3,PSOACT_","_RX,.05,"E")["CMOP Suspense Label Printed" S PTLBL=0
"RTN","PSOREJP2",278,0)
I 'PTLBL Q 0
"RTN","PSOREJP2",279,0)
;
"RTN","PSOREJP2",280,0)
; If there is an entry in the CMOP Event multiple, and it is for the
"RTN","PSOREJP2",281,0)
; current Fill, check the status. If 0/Transmitted, 1/Dispensed, or
"RTN","PSOREJP2",282,0)
; 2/Retransmitted, then do not allow the label to be printed.
"RTN","PSOREJP2",283,0)
;
"RTN","PSOREJP2",284,0)
S CMP=0
"RTN","PSOREJP2",285,0)
F S CMP=$O(^PSRX(RX,4,CMP)) Q:'CMP D Q:'PTLBL
"RTN","PSOREJP2",286,0)
. I +$$GET1^DIQ(52.01,CMP_","_RX,2,"I")'=RFL Q
"RTN","PSOREJP2",287,0)
. I "0,1,2"[$$GET1^DIQ(52.01,CMP_","_RX,3,"I") S PTLBL=0
"RTN","PSOREJP2",288,0)
I 'PTLBL Q 0
"RTN","PSOREJP2",289,0)
;
"RTN","PSOREJP2",290,0)
; - Label already printed for Rx fill?
"RTN","PSOREJP2",291,0)
S LBL=0
"RTN","PSOREJP2",292,0)
F S LBL=$O(^PSRX(RX,"L",LBL)) Q:'LBL D Q:'PTLBL
"RTN","PSOREJP2",293,0)
. I +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")'=RFL Q
"RTN","PSOREJP2",294,0)
. I '$$RXRLDT^PSOBPSUT(RX,RFL),+$$GET1^DIQ(52.032,LBL_","_RX,1,"I")=RFL,PSOBPS="e" S REPRINT=1 Q
"RTN","PSOREJP2",295,0)
. I $G(PSOTRIC)&($$RXRLDT^PSOBPSUT(RX,RFL)),PSOBPS'="e" S REPRINT=1 Q
"RTN","PSOREJP2",296,0)
. I $$GET1^DIQ(52.032,LBL_","_RX,4,"I") Q
"RTN","PSOREJP2",297,0)
. I $$GET1^DIQ(52.032,LBL_","_RX,2)["INTERACTION" Q
"RTN","PSOREJP2",298,0)
. S PTLBL=0
"RTN","PSOREJP2",299,0)
;
"RTN","PSOREJP2",300,0)
I 'PTLBL Q 0
"RTN","PSOREJP2",301,0)
;
"RTN","PSOREJP2",302,0)
N DIR,DIRUT,Y
"RTN","PSOREJP2",303,0)
W !
"RTN","PSOREJP2",304,0)
S DIR(0)="Y"
"RTN","PSOREJP2",305,0)
S DIR("A")=$S('$G(REPRINT):"Print Label",1:"Reprint Label")
"RTN","PSOREJP2",306,0)
S DIR("B")="YES"
"RTN","PSOREJP2",307,0)
I PSOBPS="e" K DIR("B")
"RTN","PSOREJP2",308,0)
D ^DIR
"RTN","PSOREJP2",309,0)
I $G(Y)=0!$D(DIRUT) S PTLBL=0
"RTN","PSOREJP2",310,0)
;
"RTN","PSOREJP2",311,0)
Q PTLBL
"RTN","PSOREJP2",312,0)
;
"RTN","PSOREJP2",313,0)
DTRNG(BGN,END) ; Date Range Selection
"RTN","PSOREJP2",314,0)
;Input: (o) BGN - Default Begin Date
"RTN","PSOREJP2",315,0)
; (o) END - Default End Date
"RTN","PSOREJP2",316,0)
;
"RTN","PSOREJP2",317,0)
N %DT,DTOUT,DUOUT,DTRNG,X,Y
"RTN","PSOREJP2",318,0)
S DTRNG=""
"RTN","PSOREJP2",319,0)
S %DT="AEST",%DT("A")="BEGIN REJECT DATE: ",%DT("B")=$G(BGN) K:$G(BGN)="" %DT("B") D ^%DT
"RTN","PSOREJP2",320,0)
I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
"RTN","PSOREJP2",321,0)
S $P(DTRNG,U)=Y
"RTN","PSOREJP2",322,0)
;
"RTN","PSOREJP2",323,0)
W ! K %DT
"RTN","PSOREJP2",324,0)
S %DT="AEST",%DT("A")="END REJECT DATE: ",%DT("B")=$G(END),%DT(0)=Y K:$G(END)="" %DT("B") D ^%DT
"RTN","PSOREJP2",325,0)
I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
"RTN","PSOREJP2",326,0)
;
"RTN","PSOREJP2",327,0)
;Define Entry
"RTN","PSOREJP2",328,0)
S $P(DTRNG,U,2)=Y
"RTN","PSOREJP2",329,0)
;
"RTN","PSOREJP2",330,0)
Q DTRNG
"RTN","PSOREJP2",331,0)
;
"RTN","PSOREJP2",332,0)
CALCSD(RX,FIL,COB) ;
"RTN","PSOREJP2",333,0)
; CALCSD - Prompt the user for Last Date of Service, Last Days Supply and
"RTN","PSOREJP2",334,0)
; then calculate the suspense date based on these input.
"RTN","PSOREJP2",335,0)
; Input
"RTN","PSOREJP2",336,0)
; RX - Prescription IEN
"RTN","PSOREJP2",337,0)
; FIL - Fill Number
"RTN","PSOREJP2",338,0)
; COB - Coordination of Benefits
"RTN","PSOREJP2",339,0)
; Return
"RTN","PSOREJP2",340,0)
; The calculated suspense date
"RTN","PSOREJP2",341,0)
;
"RTN","PSOREJP2",342,0)
N DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,LDOS,LDSUP,LDS
"RTN","PSOREJP2",343,0)
I '$G(RX) Q 0
"RTN","PSOREJP2",344,0)
I $G(FIL)="" Q 0
"RTN","PSOREJP2",345,0)
I '$G(COB) S COB=1
"RTN","PSOREJP2",346,0)
;
"RTN","PSOREJP2",347,0)
D PREVRX(RX,FIL,COB,.LDOS,.LDS) ; get the previous Rx last date of service and last days supply
"RTN","PSOREJP2",348,0)
; Prompt for Last DOS
"RTN","PSOREJP2",349,0)
S DIR(0)="D",DIR("A")="LAST DATE OF SERVICE"
"RTN","PSOREJP2",350,0)
I LDOS S DIR("B")=$$FMTE^XLFDT($G(LDOS))
"RTN","PSOREJP2",351,0)
D ^DIR
"RTN","PSOREJP2",352,0)
I $D(DIRUT) W !,"ACTION NOT TAKEN!" Q 0
"RTN","PSOREJP2",353,0)
S LDOS=Y W " ("_$$FMTE^XLFDT($G(LDOS))_")"
"RTN","PSOREJP2",354,0)
;
"RTN","PSOREJP2",355,0)
; Prompt for Last Days Supply
"RTN","PSOREJP2",356,0)
S LDSUP=LDS
"RTN","PSOREJP2",357,0)
K DIR
"RTN","PSOREJP2",358,0)
S DIR(0)="N",DIR("A")="LAST DAYS SUPPLY"
"RTN","PSOREJP2",359,0)
I LDSUP]"" S DIR("B")=+LDSUP
"RTN","PSOREJP2",360,0)
D ^DIR
"RTN","PSOREJP2",361,0)
I $D(DIRUT) W !,"ACTION NOT TAKEN!" Q 0
"RTN","PSOREJP2",362,0)
;
"RTN","PSOREJP2",363,0)
; Calculate the suspense date to be Last DOS plus 3/4 of the Last Days Supply
"RTN","PSOREJP2",364,0)
; Fractions are rounded up
"RTN","PSOREJP2",365,0)
S LDSUP=Y*.75
"RTN","PSOREJP2",366,0)
S:LDSUP["." LDSUP=(LDSUP+1)\1
"RTN","PSOREJP2",367,0)
Q $$FMADD^XLFDT(LDOS,LDSUP)
"RTN","PSOREJP2",368,0)
;
"RTN","PSOREJP2",369,0)
PREVRX(RX,RFL,COB,LDOS,LDAYS,PREVRX) ; Gather last date of service and last days supply from previous rx
"RTN","PSOREJP2",370,0)
; input: RX - Current RX
"RTN","PSOREJP2",371,0)
; RFL - Refill
"RTN","PSOREJP2",372,0)
; COB - Coordination of benefits
"RTN","PSOREJP2",373,0)
; output: LDOS - (pass by reference) Last date of service in fileman format, or ""
"RTN","PSOREJP2",374,0)
; LDAYS - (pass by reference) Last days supply in numeric format, or ""
"RTN","PSOREJP2",375,0)
; PREVRX - (pass by reference) Previous Rx for same drug, if any
"RTN","PSOREJP2",376,0)
;
"RTN","PSOREJP2",377,0)
S (LDOS,LDAYS,PREVRX)=""
"RTN","PSOREJP2",378,0)
I '$G(RX) G PREVRXQ
"RTN","PSOREJP2",379,0)
I $G(RFL)="" G PREVRXQ
"RTN","PSOREJP2",380,0)
I '$G(COB) S COB=1
"RTN","PSOREJP2",381,0)
;
"RTN","PSOREJP2",382,0)
; Original fill. Check previous Rx's.
"RTN","PSOREJP2",383,0)
;
"RTN","PSOREJP2",384,0)
I RFL=0 D
"RTN","PSOREJP2",385,0)
. N X
"RTN","PSOREJP2",386,0)
. S X=$$LAST120(RX,COB) ; other Rx 120 day time window
"RTN","PSOREJP2",387,0)
. S LDOS=$P(X,U,1) ; last date of service (older rx)
"RTN","PSOREJP2",388,0)
. S LDAYS=$P(X,U,2) ; last days supply (older rx)
"RTN","PSOREJP2",389,0)
. S PREVRX=$P(X,U,3) ; Previous Rx, if any
"RTN","PSOREJP2",390,0)
. Q
"RTN","PSOREJP2",391,0)
;
"RTN","PSOREJP2",392,0)
; refill - same RX. Get previus fill information
"RTN","PSOREJP2",393,0)
I RFL>0 D
"RTN","PSOREJP2",394,0)
. N FL
"RTN","PSOREJP2",395,0)
. F FL=(RFL-1):-1:0 D Q:LDOS ; start with the previous fill (RFL-1)
"RTN","PSOREJP2",396,0)
.. I $$STATUS^PSOBPSUT(RX,FL)="" Q ; no ECME activity - skip
"RTN","PSOREJP2",397,0)
.. I $$FIND^PSOREJUT(RX,FL,,,1) Q ; unresolved reject on worklist - skip
"RTN","PSOREJP2",398,0)
.. D GETDAT^BPSBUTL(RX,FL,COB,.LDOS,.LDAYS) ; DBIA 4719
"RTN","PSOREJP2",399,0)
.. Q
"RTN","PSOREJP2",400,0)
. Q
"RTN","PSOREJP2",401,0)
;
"RTN","PSOREJP2",402,0)
PREVRXQ ;
"RTN","PSOREJP2",403,0)
Q
"RTN","PSOREJP2",404,0)
;
"RTN","PSOREJP2",405,0)
LAST120(RX,COB) ;new tag PSO*7*421, cnf
"RTN","PSOREJP2",406,0)
; For the original fill, get the default DOS/Days Supply by getting
"RTN","PSOREJP2",407,0)
; most recent DOS from the other RXs within a time window for the same
"RTN","PSOREJP2",408,0)
; patient and drug and dosage Time window - Prescription has an
"RTN","PSOREJP2",409,0)
; expiration date that is in the future or within the last 120 days
"RTN","PSOREJP2",410,0)
; Input
"RTN","PSOREJP2",411,0)
; RX - Prescription IEN
"RTN","PSOREJP2",412,0)
; COB - coordination of benefits indicator (defaults to 1 if not passed)
"RTN","PSOREJP2",413,0)
; Output
"RTN","PSOREJP2",414,0)
; Last Date of Service ^ Last Days Supply ^ Previous Rx
"RTN","PSOREJP2",415,0)
;
"RTN","PSOREJP2",416,0)
N DOSAGE,DOSAGE1,DRUG,DRUG1,DSUP,DSUP1,EXPDT,FL
"RTN","PSOREJP2",417,0)
N LDOS,LDS,LSTFIL,PAT,PREVFL,PREVRX,QTY,QTY1,RX0,RX1,X1,X2
"RTN","PSOREJP2",418,0)
;
"RTN","PSOREJP2",419,0)
I '$G(COB) S COB=1
"RTN","PSOREJP2",420,0)
S LDOS="",LDS="",PREVRX=""
"RTN","PSOREJP2",421,0)
S RX0=$G(^PSRX(RX,0)) ; Main 0 node.
"RTN","PSOREJP2",422,0)
S PAT=$P(RX0,U,2),DRUG=$P(RX0,U,6)
"RTN","PSOREJP2",423,0)
I 'PAT!'DRUG Q "^^"
"RTN","PSOREJP2",424,0)
S QTY=+$P(RX0,U,7),DSUP=+$P(RX0,U,8),DOSAGE=""
"RTN","PSOREJP2",425,0)
I QTY,DSUP S DOSAGE=QTY/DSUP ; Dosage is ratio of Qty to Days Supply.
"RTN","PSOREJP2",426,0)
S EXPDT=$$FMADD^XLFDT(DT,-121)
"RTN","PSOREJP2",427,0)
F S EXPDT=$O(^PS(55,PAT,"P","A",EXPDT)) Q:'EXPDT D ; IA 2228.
"RTN","PSOREJP2",428,0)
. S RX1=""
"RTN","PSOREJP2",429,0)
. F S RX1=$O(^PS(55,PAT,"P","A",EXPDT,RX1)) Q:'RX1 I RX'=RX1 D
"RTN","PSOREJP2",430,0)
. . S DRUG1=$P($G(^PSRX(+RX1,0)),U,6)
"RTN","PSOREJP2",431,0)
. . I DRUG'=DRUG1 Q ; If not the same drug, skip this other Rx.
"RTN","PSOREJP2",432,0)
. . ;
"RTN","PSOREJP2",433,0)
. . S LSTFIL=$$LSTRFL^PSOBPSU1(RX1) ; Start with last fill# of this other Rx.
"RTN","PSOREJP2",434,0)
. . S X1="",X2="" ; For this other Rx, initialize the temp variables for last DOS and last days supply.
"RTN","PSOREJP2",435,0)
. . F FL=LSTFIL:-1:0 D Q:X1 ; Loop backwards until we find the latest valid DOS.
"RTN","PSOREJP2",436,0)
. . . D CHECKIT(RX1,FL,COB,.X1,.X2)
"RTN","PSOREJP2",437,0)
. . . Q
"RTN","PSOREJP2",438,0)
. . ;
"RTN","PSOREJP2",439,0)
. . I X1>LDOS S LDOS=X1,LDS=X2,PREVRX=RX1,PREVFL=FL
"RTN","PSOREJP2",440,0)
. . Q
"RTN","PSOREJP2",441,0)
. Q
"RTN","PSOREJP2",442,0)
;
"RTN","PSOREJP2",443,0)
; If a previous Rx passed all other checks, then check the dosage. If
"RTN","PSOREJP2",444,0)
; the dosage is not the same, then clear out the variables and treat as
"RTN","PSOREJP2",445,0)
; if no previous Rx was found.
"RTN","PSOREJP2",446,0)
I PREVRX'="" D
"RTN","PSOREJP2",447,0)
. S QTY1=$S(PREVFL=0:+$P($G(^PSRX(PREVRX,0)),U,7),1:+$P($G(^PSRX(PREVRX,1,PREVFL,0)),U,4))
"RTN","PSOREJP2",448,0)
. S DSUP1=$S(PREVFL=0:+$P($G(^PSRX(PREVRX,0)),U,8),1:+$P($G(^PSRX(PREVRX,1,PREVFL,0)),U,10))
"RTN","PSOREJP2",449,0)
. S DOSAGE1=""
"RTN","PSOREJP2",450,0)
. I QTY1,DSUP1 S DOSAGE1=QTY1/DSUP1
"RTN","PSOREJP2",451,0)
. I DOSAGE'=DOSAGE1 S (LDOS,LDS,PREVRX)=""
"RTN","PSOREJP2",452,0)
. Q
"RTN","PSOREJP2",453,0)
;
"RTN","PSOREJP2",454,0)
I PREVRX'="" S PREVRX=$$GET1^DIQ(52,PREVRX_",",.01) ; Pull external Rx#.
"RTN","PSOREJP2",455,0)
Q LDOS_U_LDS_U_PREVRX
"RTN","PSOREJP2",456,0)
;
"RTN","PSOREJP2",457,0)
; MRD;PSO*7.0*448 - Added CHECKIT procedure to consolidate checks that
"RTN","PSOREJP2",458,0)
; were previously being done in two different procedures (PREVRX,
"RTN","PSOREJP2",459,0)
; LAST120).
"RTN","PSOREJP2",460,0)
;
"RTN","PSOREJP2",461,0)
CHECKIT(RX,FL,COB,LDOS,LDAYS) ; Check 1 Rx/Fill for days' supply calc.
"RTN","PSOREJP2",462,0)
;
"RTN","PSOREJP2",463,0)
; Input: (r) RX - Rx IEN (#52)
"RTN","PSOREJP2",464,0)
; (o) FL - Refill#
"RTN","PSOREJP2",465,0)
; (o) COB - Payer sequence
"RTN","PSOREJP2",466,0)
; Output: LDOS - Date of service for this Rx/Fill
"RTN","PSOREJP2",467,0)
; LDAYS - Days' supply for this Rx/Fill
"RTN","PSOREJP2",468,0)
; The CHECKIT procedure determines whether a given Rx and Fill can be
"RTN","PSOREJP2",469,0)
; used in determining whether the 3/4 days' supply requirement has
"RTN","PSOREJP2",470,0)
; been met for another Rx/Fill. The Rx/Fill being checked here must
"RTN","PSOREJP2",471,0)
; meet several criteria, including the following checked by this
"RTN","PSOREJP2",472,0)
; procedure:
"RTN","PSOREJP2",473,0)
; - The Rx/Fill must be released.
"RTN","PSOREJP2",474,0)
; - The Rx status must not be Non-Verified.
"RTN","PSOREJP2",475,0)
; - The RX must not have an Expiration Date earlier than 120 days
"RTN","PSOREJP2",476,0)
; before today.
"RTN","PSOREJP2",477,0)
; - The Rx/Fill must have ECME activity.
"RTN","PSOREJP2",478,0)
; - The Rx/Fill must not have any unresolved rejects.
"RTN","PSOREJP2",479,0)
;
"RTN","PSOREJP2",480,0)
N EXPDT
"RTN","PSOREJP2",481,0)
I '$$RXRLDT^PSOBPSUT(RX,FL) Q ; If not released, Quit.
"RTN","PSOREJP2",482,0)
I $$GET1^DIQ(52,RX,100,"I")=1 Q ; If Status is NON-VERIFIED, Quit.
"RTN","PSOREJP2",483,0)
S EXPDT=$$GET1^DIQ(52,RX,26,"I") ; If Expiration Date of Rx is more
"RTN","PSOREJP2",484,0)
I EXPDT,$$FMDIFF^XLFDT(DT,EXPDT)>120 Q ; than 120 days ago, Quit.
"RTN","PSOREJP2",485,0)
I $$STATUS^PSOBPSUT(RX,FL)="" Q ; If no ECME activity, Quit.
"RTN","PSOREJP2",486,0)
I $$FIND^PSOREJUT(RX,FL,,,1) Q ; If any unresolved rejects, Quit.
"RTN","PSOREJP2",487,0)
;
"RTN","PSOREJP2",488,0)
; Pull the Date of Service and Days' Supply for this Rx/Fill.
"RTN","PSOREJP2",489,0)
;
"RTN","PSOREJP2",490,0)
D GETDAT^BPSBUTL(RX,FL,COB,.LDOS,.LDAYS) ; IA 4719.
"RTN","PSOREJP2",491,0)
Q
"RTN","PSOREJP2",492,0)
;
"RTN","PSOREJP3")
0^6^B276853501
"RTN","PSOREJP3",1,0)
PSOREJP3 ;ALB/SS - Third Party Reject Display Screen - Comments ;10/27/06
"RTN","PSOREJP3",2,0)
;;7.0;OUTPATIENT PHARMACY;**260,287,289,290,358,359,385,403,421,427,448,482,512,528**;DEC 1997;Build 8
"RTN","PSOREJP3",3,0)
;Reference to GETDAT^BPSBUTL supported by IA 4719
"RTN","PSOREJP3",4,0)
;Reference to COM^BPSSCRU3 supported by IA 6214
"RTN","PSOREJP3",5,0)
;Reference to IEN59^BPSOSRX supported by IA 4412
"RTN","PSOREJP3",6,0)
;Reference to GETPL59^BPSPRRX5 supported by IA 6939
"RTN","PSOREJP3",7,0)
;Reference to GETRTP59^BPSPRRX5 supported by IA 6939
"RTN","PSOREJP3",8,0)
;
"RTN","PSOREJP3",9,0)
COM ; Builds the Comments section in the Reject Information Screen.
"RTN","PSOREJP3",10,0)
; The following variables are assumed to exist:
"RTN","PSOREJP3",11,0)
; RX - Pointer to file# 52, Prescription.
"RTN","PSOREJP3",12,0)
; FILL - Pointer to the Refill sub-file of the Prescription.
"RTN","PSOREJP3",13,0)
; REJ - Pointer to the Reject Info sub-file of the Prescription.
"RTN","PSOREJP3",14,0)
;
"RTN","PSOREJP3",15,0)
N PSOARRAY,PSOCNT,PSOCOM,PSODATA,PSODATE,PSODATE1,PSODFN,PSOLAST,PSOPC
"RTN","PSOREJP3",16,0)
N PSOPFLAG,PSOSTATUS,PSOSTR,PSOTEMP,PSOUSER,PSOX,PSOY,X
"RTN","PSOREJP3",17,0)
;
"RTN","PSOREJP3",18,0)
; MRD;PSO*7*448 - This patch added the ability for an OPECC to flag a
"RTN","PSOREJP3",19,0)
; comment on a BPS Transaction as being for pharmacy. A comment so
"RTN","PSOREJP3",20,0)
; flagged will appear on the Reject Information Screen intermingled
"RTN","PSOREJP3",21,0)
; with any other comments on the Prescription. All the comments will
"RTN","PSOREJP3",22,0)
; be sorted in reverse chronological order.
"RTN","PSOREJP3",23,0)
;
"RTN","PSOREJP3",24,0)
; COM^BPSSCRU3 populates the array PSOTEMP with all the comments from
"RTN","PSOREJP3",25,0)
; the BPS Transaction corresponding to the Prescription and Refill.
"RTN","PSOREJP3",26,0)
; Any of those comments with the Pharmacy flag set to '1' will be
"RTN","PSOREJP3",27,0)
; added to the array PSOARRAY.
"RTN","PSOREJP3",28,0)
;
"RTN","PSOREJP3",29,0)
D COM^BPSSCRU3(RX,FILL,,.PSOTEMP) ; IA 6214.
"RTN","PSOREJP3",30,0)
;
"RTN","PSOREJP3",31,0)
S PSODATE=0
"RTN","PSOREJP3",32,0)
F S PSODATE=$O(PSOTEMP(PSODATE)) Q:'PSODATE D
"RTN","PSOREJP3",33,0)
. S PSOX=0
"RTN","PSOREJP3",34,0)
. F S PSOX=$O(PSOTEMP(PSODATE,PSOX)) Q:'PSOX D
"RTN","PSOREJP3",35,0)
. . ;
"RTN","PSOREJP3",36,0)
. . ; If the Pharmacy flag is set, then add this comment to the
"RTN","PSOREJP3",37,0)
. . ; array PSOARRAY to be displayed.
"RTN","PSOREJP3",38,0)
. . ;
"RTN","PSOREJP3",39,0)
. . S PSOPFLAG=$P(PSOTEMP(PSODATE,PSOX),U)
"RTN","PSOREJP3",40,0)
. . I 'PSOPFLAG Q
"RTN","PSOREJP3",41,0)
. . S PSOCOM=$P(PSOTEMP(PSODATE,PSOX),U,2)
"RTN","PSOREJP3",42,0)
. . S PSOUSER=$P(PSOTEMP(PSODATE,PSOX),U,3)
"RTN","PSOREJP3",43,0)
. . S PSOUSER=$$GET1^DIQ(200,PSOUSER,.01)
"RTN","PSOREJP3",44,0)
. . S PSOY=$$FMTE^XLFDT(PSODATE)
"RTN","PSOREJP3",45,0)
. . S PSOCOM=PSOY_" (OPECC) - "_PSOCOM_" ("_PSOUSER_")"
"RTN","PSOREJP3",46,0)
. . S PSOY=$G(PSOARRAY(PSODATE))+1
"RTN","PSOREJP3",47,0)
. . S PSOARRAY(PSODATE)=PSOY
"RTN","PSOREJP3",48,0)
. . S PSOARRAY(PSODATE,PSOY)=PSOCOM
"RTN","PSOREJP3",49,0)
. . Q
"RTN","PSOREJP3",50,0)
. Q
"RTN","PSOREJP3",51,0)
;
"RTN","PSOREJP3",52,0)
; Pull comments from the Reject sub-file of the Prescription and
"RTN","PSOREJP3",53,0)
; add to the array PSOARRAY.
"RTN","PSOREJP3",54,0)
;
"RTN","PSOREJP3",55,0)
S PSOX=0
"RTN","PSOREJP3",56,0)
F S PSOX=$O(^PSRX(RX,"REJ",REJ,"COM",PSOX)) Q:'PSOX D
"RTN","PSOREJP3",57,0)
. S PSODATE=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,.01,"E")
"RTN","PSOREJP3",58,0)
. S PSOUSER=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,1)
"RTN","PSOREJP3",59,0)
. S PSOCOM=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,2)
"RTN","PSOREJP3",60,0)
. S PSOCOM=PSODATE_" - "_PSOCOM_" ("_PSOUSER_")"
"RTN","PSOREJP3",61,0)
. S PSODATE=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,.01,"I")
"RTN","PSOREJP3",62,0)
. S PSOY=$G(PSOARRAY(PSODATE))+1
"RTN","PSOREJP3",63,0)
. S PSOARRAY(PSODATE)=PSOY
"RTN","PSOREJP3",64,0)
. S PSOARRAY(PSODATE,PSOY)=PSOCOM
"RTN","PSOREJP3",65,0)
. Q
"RTN","PSOREJP3",66,0)
;
"RTN","PSOREJP3",67,0)
; At this point, all of the comments to be displayed are in the array
"RTN","PSOREJP3",68,0)
; PSOARRAY, sorted by date/time. If that array is empty, then skip
"RTN","PSOREJP3",69,0)
; down to PTC. Otherwise, loop through the comments backwards to
"RTN","PSOREJP3",70,0)
; display in reverse chronological order.
"RTN","PSOREJP3",71,0)
;
"RTN","PSOREJP3",72,0)
I '$O(PSOARRAY("")) G PTC
"RTN","PSOREJP3",73,0)
D SETLN^PSOREJP1()
"RTN","PSOREJP3",74,0)
D SETLN^PSOREJP1("COMMENTS - REJECT",1,1)
"RTN","PSOREJP3",75,0)
;
"RTN","PSOREJP3",76,0)
S PSODATE=""
"RTN","PSOREJP3",77,0)
F S PSODATE=$O(PSOARRAY(PSODATE),-1) Q:'PSODATE D
"RTN","PSOREJP3",78,0)
. S PSOX=""
"RTN","PSOREJP3",79,0)
. F S PSOX=$O(PSOARRAY(PSODATE,PSOX),-1) Q:'PSOX D
"RTN","PSOREJP3",80,0)
. . ;
"RTN","PSOREJP3",81,0)
. . ; Use ^DIWP utility to put comment into scratch global array,
"RTN","PSOREJP3",82,0)
. . ; with lines broken apart intelligently.
"RTN","PSOREJP3",83,0)
. . ;
"RTN","PSOREJP3",84,0)
. . N %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z
"RTN","PSOREJP3",85,0)
. . K ^UTILITY($J,"W")
"RTN","PSOREJP3",86,0)
. . S X=PSOARRAY(PSODATE,PSOX)
"RTN","PSOREJP3",87,0)
. . S DIWL=1
"RTN","PSOREJP3",88,0)
. . S DIWR=78
"RTN","PSOREJP3",89,0)
. . D ^DIWP
"RTN","PSOREJP3",90,0)
. . ;
"RTN","PSOREJP3",91,0)
. . ; Loop through the scratch array and add each line to the ^TMP
"RTN","PSOREJP3",92,0)
. . ; global to be displayed on the screen.
"RTN","PSOREJP3",93,0)
. . ;
"RTN","PSOREJP3",94,0)
. . S PSOLAST=0
"RTN","PSOREJP3",95,0)
. . F PSOY=1:1 Q:('$D(^UTILITY($J,"W",1,PSOY,0))) D
"RTN","PSOREJP3",96,0)
. . . S PSOCOM=$G(^UTILITY($J,"W",1,PSOY,0))
"RTN","PSOREJP3",97,0)
. . . ;
"RTN","PSOREJP3",98,0)
. . . ; If this line is the last of this comment, and this is the
"RTN","PSOREJP3",99,0)
. . . ; last comment, then Set PSOLAST=1 to make this line underlined
"RTN","PSOREJP3",100,0)
. . . ; on the screen.
"RTN","PSOREJP3",101,0)
. . . ;
"RTN","PSOREJP3",102,0)
. . . I '$D(^UTILITY($J,"W",1,PSOY+1)),$O(PSOARRAY(PSODATE,PSOX),-1)="",$O(PSOARRAY(PSODATE),-1)="" S PSOLAST=1
"RTN","PSOREJP3",103,0)
. . . ;
"RTN","PSOREJP3",104,0)
. . . ; Use SETLN^PSOREJP1 to add line to ^TMP array to be displayed to screen.
"RTN","PSOREJP3",105,0)
. . . ;
"RTN","PSOREJP3",106,0)
. . . D SETLN^PSOREJP1($S(PSOY=1:"- ",1:" ")_PSOCOM,0,PSOLAST,1)
"RTN","PSOREJP3",107,0)
. . . Q
"RTN","PSOREJP3",108,0)
. . Q
"RTN","PSOREJP3",109,0)
. Q
"RTN","PSOREJP3",110,0)
;
"RTN","PSOREJP3",111,0)
PTC ; Patient Comments
"RTN","PSOREJP3",112,0)
;
"RTN","PSOREJP3",113,0)
K PSOARRAY
"RTN","PSOREJP3",114,0)
;
"RTN","PSOREJP3",115,0)
; Get Patient ID - If no Patient Comments on file, Quit
"RTN","PSOREJP3",116,0)
S PSODFN=$$GET1^DIQ(52,RX,2,"I")
"RTN","PSOREJP3",117,0)
I '$D(^PS(55,PSODFN,"PC")) Q
"RTN","PSOREJP3",118,0)
;
"RTN","PSOREJP3",119,0)
; Loop through Patient Comments - Add ACTIVE Comments to PSOAR array
"RTN","PSOREJP3",120,0)
S PSODATE=""
"RTN","PSOREJP3",121,0)
S PSOCNT=0
"RTN","PSOREJP3",122,0)
K PSOAR
"RTN","PSOREJP3",123,0)
F S PSODATE=$O(^PS(55,PSODFN,"PC","B",PSODATE)) Q:PSODATE="" D
"RTN","PSOREJP3",124,0)
. S PSOPC=""
"RTN","PSOREJP3",125,0)
. F S PSOPC=$O(^PS(55,PSODFN,"PC","B",PSODATE,PSOPC)) Q:PSOPC="" D
"RTN","PSOREJP3",126,0)
. . K PSODATA
"RTN","PSOREJP3",127,0)
. . D GETS^DIQ(55.17,PSOPC_","_PSODFN_",",".01;1;2;3","IE","PSODATA")
"RTN","PSOREJP3",128,0)
. . ;
"RTN","PSOREJP3",129,0)
. . ; Only display ACTIVE Patient Comments
"RTN","PSOREJP3",130,0)
. . S PSOSTATUS=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",2,"I"))
"RTN","PSOREJP3",131,0)
. . I PSOSTATUS'="Y" Q
"RTN","PSOREJP3",132,0)
. . ;
"RTN","PSOREJP3",133,0)
. . S PSODATE1=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",.01,"E"))
"RTN","PSOREJP3",134,0)
. . S PSOUSER=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",1,"E"))
"RTN","PSOREJP3",135,0)
. . S PSOCOM=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",3,"E"))
"RTN","PSOREJP3",136,0)
. . S PSOSTR=PSODATE1_" - "_PSOCOM_" ("_PSOUSER_")"
"RTN","PSOREJP3",137,0)
. . S PSOCNT=PSOCNT+1
"RTN","PSOREJP3",138,0)
. . S PSOARRAY(PSOCNT)=PSOSTR
"RTN","PSOREJP3",139,0)
;
"RTN","PSOREJP3",140,0)
; If PSOAR array exists, display Active Patient Comments
"RTN","PSOREJP3",141,0)
I $D(PSOARRAY) D
"RTN","PSOREJP3",142,0)
. D SETLN^PSOREJP1("COMMENTS - PATIENT",1,1)
"RTN","PSOREJP3",143,0)
. ;
"RTN","PSOREJP3",144,0)
. ; Loop through PSOAR in reverse order to display Patient
"RTN","PSOREJP3",145,0)
. ; Comments in reverse chronological order
"RTN","PSOREJP3",146,0)
. S PSOCNT=""
"RTN","PSOREJP3",147,0)
. F S PSOCNT=$O(PSOARRAY(PSOCNT),-1) Q:PSOCNT="" D
"RTN","PSOREJP3",148,0)
. . ;
"RTN","PSOREJP3",149,0)
. . ; Use ^DIWP to display Patient Comments with proper
"RTN","PSOREJP3",150,0)
. . ; line breaking
"RTN","PSOREJP3",151,0)
. . N %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z
"RTN","PSOREJP3",152,0)
. . K ^UTILITY($J,"W")
"RTN","PSOREJP3",153,0)
. . S X=PSOARRAY(PSOCNT)
"RTN","PSOREJP3",154,0)
. . S DIWL=1
"RTN","PSOREJP3",155,0)
. . S DIWR=78
"RTN","PSOREJP3",156,0)
. . D ^DIWP
"RTN","PSOREJP3",157,0)
. . ;
"RTN","PSOREJP3",158,0)
. . S PSOLAST=0
"RTN","PSOREJP3",159,0)
. . F PSOY=1:1 Q:('$D(^UTILITY($J,"W",1,PSOY,0))) D
"RTN","PSOREJP3",160,0)
. . . S PSOCOM=$G(^UTILITY($J,"W",1,PSOY,0))
"RTN","PSOREJP3",161,0)
. . . ;
"RTN","PSOREJP3",162,0)
. . . ; Looping through the array in reverse order means PSOCNT=1
"RTN","PSOREJP3",163,0)
. . . ; will be the last comment to display. If the last line of the
"RTN","PSOREJP3",164,0)
. . . ; last comment is being displayed, set PSOLAST=1 to underline
"RTN","PSOREJP3",165,0)
. . . ; the comment on the screen.
"RTN","PSOREJP3",166,0)
. . . ;
"RTN","PSOREJP3",167,0)
. . . I '$D(^UTILITY($J,"W",1,PSOY+1)),PSOCNT=1 S PSOLAST=1
"RTN","PSOREJP3",168,0)
. . . ;
"RTN","PSOREJP3",169,0)
. . . ; Use SETLN^PSOREJP1 to add line to ^TMP array to be displayed to screen.
"RTN","PSOREJP3",170,0)
. . . ;
"RTN","PSOREJP3",171,0)
. . . D SETLN^PSOREJP1($S(PSOY=1:"- ",1:" ")_PSOCOM,0,PSOLAST,1)
"RTN","PSOREJP3",172,0)
;
"RTN","PSOREJP3",173,0)
K ^UTILITY($J,"W")
"RTN","PSOREJP3",174,0)
;
"RTN","PSOREJP3",175,0)
Q
"RTN","PSOREJP3",176,0)
;
"RTN","PSOREJP3",177,0)
ADDCOM ; - Add comment worklist action
"RTN","PSOREJP3",178,0)
N DIR,PSO55,PSCOM,PSOCOMTYPE
"RTN","PSOREJP3",179,0)
D FULL^VALM1
"RTN","PSOREJP3",180,0)
;
"RTN","PSOREJP3",181,0)
S DIR(0)="S^R:Reject;P:Patient Billing"
"RTN","PSOREJP3",182,0)
S DIR("A")="Comment Type"
"RTN","PSOREJP3",183,0)
S DIR("?",1)="The Reject Comment only displays for the specific reject."
"RTN","PSOREJP3",184,0)
S DIR("?")="The Patient Billing Comment displays on all rejects for the patient."
"RTN","PSOREJP3",185,0)
D ^DIR
"RTN","PSOREJP3",186,0)
I $D(DIRUT) S VALMBCK="R" Q
"RTN","PSOREJP3",187,0)
S PSOCOMTYPE=Y
"RTN","PSOREJP3",188,0)
;
"RTN","PSOREJP3",189,0)
I PSOCOMTYPE="P",'$D(^XUSEC("PSO EPHARMACY SITE MANAGER",DUZ)) D S VALMBCK="R" Q
"RTN","PSOREJP3",190,0)
. W !,"Patient Billing Comments require Pharmacy Key (PSO EPHARMACY SITE MANAGER)"
"RTN","PSOREJP3",191,0)
. D WAIT^VALM1
"RTN","PSOREJP3",192,0)
;
"RTN","PSOREJP3",193,0)
S PSCOM=$$COMMENT("Comment: ",150)
"RTN","PSOREJP3",194,0)
;
"RTN","PSOREJP3",195,0)
; Save Reject Type Comment
"RTN","PSOREJP3",196,0)
I PSOCOMTYPE="R",$L(PSCOM)>0,PSCOM'["^" D
"RTN","PSOREJP3",197,0)
. D SAVECOM(RX,REJ,PSCOM) ;save the comment
"RTN","PSOREJP3",198,0)
. D INIT^PSOREJP1 ;update screen
"RTN","PSOREJP3",199,0)
; Save Patient Billing Type Comment
"RTN","PSOREJP3",200,0)
I PSOCOMTYPE="P",$L(PSCOM)>0,PSCOM'["^" D
"RTN","PSOREJP3",201,0)
. S PSO55=$$GET1^DIQ(52,RX,2,"I")
"RTN","PSOREJP3",202,0)
. D ADDPC^PSOPTC0(PSCOM,PSO55)
"RTN","PSOREJP3",203,0)
. D INIT^PSOREJP1
"RTN","PSOREJP3",204,0)
S VALMBCK="R"
"RTN","PSOREJP3",205,0)
Q
"RTN","PSOREJP3",206,0)
;
"RTN","PSOREJP3",207,0)
;Enter a comment
"RTN","PSOREJP3",208,0)
;PSOTR -prompt string
"RTN","PSOREJP3",209,0)
;PSMLEN -maxlen
"RTN","PSOREJP3",210,0)
;returns:
"RTN","PSOREJP3",211,0)
; "^" - if user chose to quit
"RTN","PSOREJP3",212,0)
; "" - nothing entered or input has been discarded
"RTN","PSOREJP3",213,0)
; otherwise - comment's text
"RTN","PSOREJP3",214,0)
COMMENT(PSOTR,PSMLEN) ;*/
"RTN","PSOREJP3",215,0)
N DIR,DTOUT,DUOUT,PSQ
"RTN","PSOREJP3",216,0)
I '$D(PSOTR) S PSOTR="Comment "
"RTN","PSOREJP3",217,0)
I '$D(PSMLEN) S PSMLEN=150
"RTN","PSOREJP3",218,0)
S DIR(0)="FA^1:150"
"RTN","PSOREJP3",219,0)
S DIR("A")=PSOTR
"RTN","PSOREJP3",220,0)
S DIR("?")="Enter a free text comment up to 150 characters long."
"RTN","PSOREJP3",221,0)
S PSQ=0
"RTN","PSOREJP3",222,0)
F D Q:+PSQ'=0
"RTN","PSOREJP3",223,0)
. W ! D ^DIR
"RTN","PSOREJP3",224,0)
. I $D(DUOUT)!($D(DTOUT)) S PSQ=-1 Q
"RTN","PSOREJP3",225,0)
. I $L(Y)'>PSMLEN S PSQ=1 Q
"RTN","PSOREJP3",226,0)
. W !!,"Enter a free text comment up to 150 characters long.",!
"RTN","PSOREJP3",227,0)
. S DIR("B")=$E(Y,1,PSMLEN)
"RTN","PSOREJP3",228,0)
Q:PSQ<0 "^"
"RTN","PSOREJP3",229,0)
Q:$L(Y)=0 ""
"RTN","PSOREJP3",230,0)
S PSQ=$$YESNO("Confirm","YES")
"RTN","PSOREJP3",231,0)
I PSQ=-1 Q "^"
"RTN","PSOREJP3",232,0)
I PSQ=0 Q ""
"RTN","PSOREJP3",233,0)
Q Y
"RTN","PSOREJP3",234,0)
;
"RTN","PSOREJP3",235,0)
; Ask
"RTN","PSOREJP3",236,0)
; Input:
"RTN","PSOREJP3",237,0)
; PSQSTR - question
"RTN","PSOREJP3",238,0)
; PSDFL - default answer
"RTN","PSOREJP3",239,0)
; Output:
"RTN","PSOREJP3",240,0)
; 1 YES
"RTN","PSOREJP3",241,0)
; 0 NO
"RTN","PSOREJP3",242,0)
; -1 if cancelled
"RTN","PSOREJP3",243,0)
YESNO(PSQSTR,PSDFL) ; Default - YES
"RTN","PSOREJP3",244,0)
N DIR,Y,DUOUT
"RTN","PSOREJP3",245,0)
S DIR(0)="Y"
"RTN","PSOREJP3",246,0)
S DIR("A")=PSQSTR
"RTN","PSOREJP3",247,0)
S:$L($G(PSDFL)) DIR("B")=PSDFL
"RTN","PSOREJP3",248,0)
W ! D ^DIR
"RTN","PSOREJP3",249,0)
Q $S($G(DUOUT)!$G(DUOUT)!(Y="^"):-1,1:Y)
"RTN","PSOREJP3",250,0)
;
"RTN","PSOREJP3",251,0)
;Save comment
"RTN","PSOREJP3",252,0)
SAVECOM(PSRXIEN,PSREJIEN,PSCOMNT,DATETIME,USER) ;
"RTN","PSOREJP3",253,0)
N PSREC,PSDA,PSERR
"RTN","PSOREJP3",254,0)
I '$G(DATETIME) D NOW^%DTC S DATETIME=%
"RTN","PSOREJP3",255,0)
I '$G(USER) S USER=DUZ
"RTN","PSOREJP3",256,0)
D INSITEM(52.2551,PSRXIEN,PSREJIEN,DATETIME)
"RTN","PSOREJP3",257,0)
S PSREC=$O(^PSRX(PSRXIEN,"REJ",PSREJIEN,"COM","B",DATETIME,0))
"RTN","PSOREJP3",258,0)
I PSREC>0 D
"RTN","PSOREJP3",259,0)
. S PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",1)=USER
"RTN","PSOREJP3",260,0)
. S PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",2)=$G(PSCOMNT)
"RTN","PSOREJP3",261,0)
. D FILE^DIE("","PSDA","PSERR")
"RTN","PSOREJP3",262,0)
Q
"RTN","PSOREJP3",263,0)
;
"RTN","PSOREJP3",264,0)
;/**
"RTN","PSOREJP3",265,0)
;PSSFILE - subfile# (52.2551) for comment
"RTN","PSOREJP3",266,0)
;PSIEN - ien for file in which the new subfile entry will be inserted
"RTN","PSOREJP3",267,0)
;PSVAL01 - .01 value for the new entry
"RTN","PSOREJP3",268,0)
INSITEM(PSSFILE,PSIEN0,PSIEN1,PSVAL01) ;*/
"RTN","PSOREJP3",269,0)
N PSSSI,PSIENS,PSFDA,PSER
"RTN","PSOREJP3",270,0)
S PSIENS="+1,"_PSIEN1_","_PSIEN0_","
"RTN","PSOREJP3",271,0)
S PSFDA(PSSFILE,PSIENS,.01)=PSVAL01
"RTN","PSOREJP3",272,0)
D UPDATE^DIE("","PSFDA","PSSSI","PSER")
"RTN","PSOREJP3",273,0)
I $D(PSER) D BMES^XPDUTL(PSER("DIERR",1,"TEXT",1))
"RTN","PSOREJP3",274,0)
Q
"RTN","PSOREJP3",275,0)
;
"RTN","PSOREJP3",276,0)
PRINT(RX,RFL) ; Print Label for specific Rx/Fill
"RTN","PSOREJP3",277,0)
I '$G(RX) Q
"RTN","PSOREJP3",278,0)
I $G(RFL)="" Q
"RTN","PSOREJP3",279,0)
;
"RTN","PSOREJP3",280,0)
; Some of these variables are used by LBL^PSOLSET but they are newed here
"RTN","PSOREJP3",281,0)
N PPL,PSOSITE,PSOPAR,PSOSYS,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG,PSOCLBL
"RTN","PSOREJP3",282,0)
N PSOQUIT,PSOPIOST,PSOLTEST,PSOTLBL,PSORXT
"RTN","PSOREJP3",283,0)
N DFN,PDUZ,RXFL,REPRINT,REJLBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PSOREJP3",284,0)
N %ZIS,IOP,POP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTDTH,VAR
"RTN","PSOREJP3",285,0)
;
"RTN","PSOREJP3",286,0)
; Set the default label printer. We need to new it so we don't change the value that was
"RTN","PSOREJP3",287,0)
; set by PSOLSET when the user first logged into OP so need to do a bit of work to new it and
"RTN","PSOREJP3",288,0)
; reset it before the call to LBL^PSOLSET.
"RTN","PSOREJP3",289,0)
I $G(PSOLAP)]"" S PSOTLBL=PSOLAP N PSOLAP S PSOLAP=PSOTLBL,PSOCLBL=1
"RTN","PSOREJP3",290,0)
E N PSOLAP S PSOCLBL=""
"RTN","PSOREJP3",291,0)
;
"RTN","PSOREJP3",292,0)
; Check if a label has already been printed and set REPRINT flag.
"RTN","PSOREJP3",293,0)
S REJLBL=0 F S REJLBL=$O(^PSRX(RX,"L",REJLBL)) Q:'REJLBL I +$$GET1^DIQ(52.032,REJLBL_","_RX,1,"I")=RFL S REPRINT=1 Q
"RTN","PSOREJP3",294,0)
;
"RTN","PSOREJP3",295,0)
; Define required variables
"RTN","PSOREJP3",296,0)
S PSOSITE=+$$RXSITE^PSOBPSUT(RX,RFL),PSOPAR=$G(^PS(59,PSOSITE,1))
"RTN","PSOREJP3",297,0)
S DFN=$$GET1^DIQ(52,RX,2,"I"),PDUZ=DUZ,PSOSYS=$G(^PS(59.7,1,40.1))
"RTN","PSOREJP3",298,0)
S PPL=RX I RFL S RXFL(RX)=RFL
"RTN","PSOREJP3",299,0)
;
"RTN","PSOREJP3",300,0)
; Get label print device and check alignment
"RTN","PSOREJP3",301,0)
W ! S PSOBFLAG=1 D LBL^PSOLSET I $G(PSOQUIT) Q
"RTN","PSOREJP3",302,0)
I $G(PSOLAP)="" W $C(7),!!,"No printer defined" K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR Q
"RTN","PSOREJP3",303,0)
;
"RTN","PSOREJP3",304,0)
; Call %ZIS to get device characteristics w/o reopening the printer.
"RTN","PSOREJP3",305,0)
; We need to do this to check if queuing is forced for this device
"RTN","PSOREJP3",306,0)
; Not checking the POP variable. If we don't get the device here, we will fall through to the
"RTN","PSOREJP3",307,0)
; foreground process and try again
"RTN","PSOREJP3",308,0)
S IOP=PSOLAP,%ZIS="QN" D ^%ZIS
"RTN","PSOREJP3",309,0)
;
"RTN","PSOREJP3",310,0)
; If background printer, queue the job
"RTN","PSOREJP3",311,0)
I $D(IO("Q")) D Q
"RTN","PSOREJP3",312,0)
. S ZTRTN="DQ^PSOLBL",ZTDTH=$H,ZTIO=PSOLAP
"RTN","PSOREJP3",313,0)
. F VAR="PSOSYS","DFN","PSOPAR","PDUZ","PCOMX","PSOLAP","PPL","PSOSITE","RXY","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP","REPRINT" S:$D(@VAR) ZTSAVE(VAR)=""
"RTN","PSOREJP3",314,0)
. S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""
"RTN","PSOREJP3",315,0)
. S ZTDESC="OUTPATIENT PHARMACY REJECT WORKLIST LABEL PRINT"
"RTN","PSOREJP3",316,0)
. D ^%ZISC,^%ZTLOAD
"RTN","PSOREJP3",317,0)
. W !!,"Label ",$S('$D(ZTSK):"NOT ",1:""),"queued to print",! I '$D(ZTSK) W $C(7) K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR
"RTN","PSOREJP3",318,0)
;
"RTN","PSOREJP3",319,0)
; If we gotten this far, open the device and print the label in the foreground
"RTN","PSOREJP3",320,0)
; We also need to preserve the PSORX array, which gets killed by DQ^PSOLBL
"RTN","PSOREJP3",321,0)
K %ZIS S IOP=PSOLAP D ^%ZIS
"RTN","PSOREJP3",322,0)
I POP D ^%ZISC W $C(7),!!,"Printer is busy - NO label printed" K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR Q
"RTN","PSOREJP3",323,0)
K PSORXT M PSORXT=PSORX
"RTN","PSOREJP3",324,0)
D DQ^PSOLBL,^%ZISC
"RTN","PSOREJP3",325,0)
K PSORX M PSORX=PSORXT
"RTN","PSOREJP3",326,0)
Q
"RTN","PSOREJP3",327,0)
;
"RTN","PSOREJP3",328,0)
RXINFO(RX,FILL,LINE,REJ) ; Returns header displayable Rx Information
"RTN","PSOREJP3",329,0)
N TXT,RXINFO,LBL,CMOP,DRG,PSOET
"RTN","PSOREJP3",330,0)
I LINE=1 D
"RTN","PSOREJP3",331,0)
. N RXDOS D GETDAT^BPSBUTL(RX,FILL,,.RXDOS) ; Get Date of Service from BPS CLAIM field 401 - PSO*7*421
"RTN","PSOREJP3",332,0)
. S RXINFO="Rx# : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL
"RTN","PSOREJP3",333,0)
. ;cnf, PSO*7*358, add PSOET logic for TRICARE/CHAMPVA non-billable
"RTN","PSOREJP3",334,0)
. S PSOET=$$PSOET(RX,FILL)
"RTN","PSOREJP3",335,0)
. S $E(RXINFO,27)="ECME#: "_$S(PSOET:"",1:$$ECMENUM^PSOBPSU2(RX,FILL))
"RTN","PSOREJP3",336,0)
. S $E(RXINFO,49)="Date of Service: "_$S(PSOET:"",1:$$FMTE^XLFDT(RXDOS)) ; Use DOS from BPS Claims field 401 - PSO*7*421
"RTN","PSOREJP3",337,0)
I LINE=2 D
"RTN","PSOREJP3",338,0)
. S DRG=$$GET1^DIQ(52,RX,6,"I"),CMOP=$S($D(^PSDRUG("AQ",DRG)):1,1:0)
"RTN","PSOREJP3",339,0)
. S RXINFO=$S(CMOP:"CMOP ",1:"")_"Drug",$E(RXINFO,10)=": "_$E($$GET1^DIQ(52,RX,6),1,43)
"RTN","PSOREJP3",340,0)
. S $E(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL)
"RTN","PSOREJP3",341,0)
Q $G(RXINFO)
"RTN","PSOREJP3",342,0)
;
"RTN","PSOREJP3",343,0)
FILL ;Fill payable TRICARE or CHAMPVA Rx
"RTN","PSOREJP3",344,0)
N COM,I,OPNREJ,OPNREJ2,OPNREJ3,DCSTAT,PSOREL
"RTN","PSOREJP3",345,0)
S:'$G(PSOTRIC) PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC) ;cnf, PSO*7*358, add line
"RTN","PSOREJP3",346,0)
;cnf, PSO*7*358, don't allow option if TRICARE/CHAMPVA and released, PSOREL is set to the release date
"RTN","PSOREJP3",347,0)
S PSOREL=0 I PSOTRIC D
"RTN","PSOREJP3",348,0)
. I 'FILL S PSOREL=+$$GET1^DIQ(52,RX,31,"I")
"RTN","PSOREJP3",349,0)
. I FILL S PSOREL=+$$GET1^DIQ(52.1,FILL_","_RX,17,"I")
"RTN","PSOREJP3",350,0)
I PSOREL S VALMSG="Released Rxs may not be filled.",VALMBCK="R" Q
"RTN","PSOREJP3",351,0)
;cnf, PSO*7*358, don't allow option if prescription has been discontinued
"RTN","PSOREJP3",352,0)
; 12 - DISCONTINUED
"RTN","PSOREJP3",353,0)
; 14 - DISCONTINUED BY PROVIDER
"RTN","PSOREJP3",354,0)
; 15 - DISCONTINUED (EDIT)
"RTN","PSOREJP3",355,0)
S DCSTAT=$$GET1^DIQ(52,RX,100,"I")
"RTN","PSOREJP3",356,0)
I "/12/14/15/"[("/"_DCSTAT_"/") S VALMSG="Discontinued Rxs may not be filled.",VALMBCK="R" Q
"RTN","PSOREJP3",357,0)
D FULL^VALM1
"RTN","PSOREJP3",358,0)
I $$CLOSED^PSOREJP1(RX,REJ) D Q
"RTN","PSOREJP3",359,0)
. S VALMSG="This Reject is marked resolved!",VALMBCK="R"
"RTN","PSOREJP3",360,0)
;cnf, PSO*7*358
"RTN","PSOREJP3",361,0)
S COM=""
"RTN","PSOREJP3",362,0)
I 'PSOTRIC&($$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE") S VALMSG="Only Rxs with an E PAYABLE status may be filled.",VALMBCK="R" Q
"RTN","PSOREJP3",363,0)
I PSOTRIC&($$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE") D FILLTR I $L($G(VALMSG)_$G(VALMBCK)) Q ;cnf, PSO*7*358
"RTN","PSOREJP3",364,0)
S:COM="" COM="AUTOMATICALLY CLOSED" ;cnf, PSO*7*358, add condition
"RTN","PSOREJP3",365,0)
S (OPNREJ,OPNREJ2,OPNREJ3)=""
"RTN","PSOREJP3",366,0)
S OPNREJ2=0 F S OPNREJ2=$O(^PSRX(RX,"REJ",OPNREJ2)) Q:OPNREJ2=""!(OPNREJ2'?1N.N) S OPNREJ=OPNREJ_","_OPNREJ2
"RTN","PSOREJP3",367,0)
S OPNREJ=$E(OPNREJ,2,999),OPNREJ2=""
"RTN","PSOREJP3",368,0)
W !?20,"[Closing all rejections for prescription "_$$GET1^DIQ(52,RX,".01")_":"
"RTN","PSOREJP3",369,0)
F I=1:1 S OPNREJ2=$P(OPNREJ,",",I) Q:OPNREJ2="" D
"RTN","PSOREJP3",370,0)
. S OPNREJ3="",OPNREJ3=$$GET1^DIQ(52.25,OPNREJ2_","_RX,".01")
"RTN","PSOREJP3",371,0)
. W !?25,OPNREJ3_" - "_$$GET1^DIQ(9002313.93,OPNREJ3,".02")_"..."
"RTN","PSOREJP3",372,0)
. D CLOSE^PSOREJUT(RX,FILL,OPNREJ2,DUZ,6,COM,"","","","","",1) W "OK]",!,$C(7) H 1 ; pso*7*421 Use 12th param to ignore
"RTN","PSOREJP3",373,0)
I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL)
"RTN","PSOREJP3",374,0)
S CHANGE=1 ;cnf, PSO*7*358, remove S VALMBCK="R" so user goes back to selection list
"RTN","PSOREJP3",375,0)
Q
"RTN","PSOREJP3",376,0)
;
"RTN","PSOREJP3",377,0)
PSOCOB(RX,FILL,REJ) ; Returns RXCOB indicator for Worklist
"RTN","PSOREJP3",378,0)
N DATA1
"RTN","PSOREJP3",379,0)
D GET^PSOREJU2(RX,FILL,.DATA1,REJ,1)
"RTN","PSOREJP3",380,0)
I $G(DATA1(REJ,"COB"))="PRIMARY" Q 1
"RTN","PSOREJP3",381,0)
I $G(DATA1(REJ,"COB"))="" Q 1
"RTN","PSOREJP3",382,0)
Q 2
"RTN","PSOREJP3",383,0)
;
"RTN","PSOREJP3",384,0)
DC ;Discontinue TRICARE Rx
"RTN","PSOREJP3",385,0)
N ACTION S ACTION="D"
"RTN","PSOREJP3",386,0)
D FULL^VALM1
"RTN","PSOREJP3",387,0)
S ACTION=$$DC^PSOREJU1(RX,ACTION)
"RTN","PSOREJP3",388,0)
I ACTION="Q"!(ACTION="^") S VALMSG="NO ACTION TAKEN.",VALMBCK="R" Q
"RTN","PSOREJP3",389,0)
S CHANGE=1
"RTN","PSOREJP3",390,0)
Q
"RTN","PSOREJP3",391,0)
;
"RTN","PSOREJP3",392,0)
FILLTR ;TRICARE/CHAMPVA specific logic ;cnf, PSO*7*358
"RTN","PSOREJP3",393,0)
;COM is not new'd so the variable can be used in FILL tag
"RTN","PSOREJP3",394,0)
N CONT,PSOETEC,PSQSTR
"RTN","PSOREJP3",395,0)
;
"RTN","PSOREJP3",396,0)
FILLTR2 ;Use for looping if user enters ^ in required comment field ;cnf, PSO*7*358
"RTN","PSOREJP3",397,0)
;
"RTN","PSOREJP3",398,0)
;if TRICARE/CHAMPVA, not payable, and no security key, quit
"RTN","PSOREJP3",399,0)
;reference to ^XUSEC( supported by IA 10076
"RTN","PSOREJP3",400,0)
I '$D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S VALMSG="Action Requires <PSO TRICARE/CHAMPVA> security key",VALMBCK="R" Q
"RTN","PSOREJP3",401,0)
;
"RTN","PSOREJP3",402,0)
;if TRICARE/CHAMPVA, not payable, and user has security key, prompt to continue or not
"RTN","PSOREJP3",403,0)
S PSQSTR="You are bypassing claims processing. Do you wish to continue"
"RTN","PSOREJP3",404,0)
S CONT=$$YESNO(PSQSTR,"No")
"RTN","PSOREJP3",405,0)
I (CONT=-1)!('CONT) S VALMSG="NO ACTION TAKEN.",VALMBCK="R" Q
"RTN","PSOREJP3",406,0)
;
"RTN","PSOREJP3",407,0)
;check for valid electronic signature
"RTN","PSOREJP3",408,0)
I '$$SIG^PSOREJU1() S VALMBCK="R" Q ;quit if no valid electronic signature
"RTN","PSOREJP3",409,0)
;
"RTN","PSOREJP3",410,0)
;prompt user for required TRICARE/CHAMPVA Justification
"RTN","PSOREJP3",411,0)
S COM=$$TCOM(RX,FILL) G:COM="^" FILLTR2 ;loop back to "continue?" question if ^ entry
"RTN","PSOREJP3",412,0)
;
"RTN","PSOREJP3",413,0)
;audit log
"RTN","PSOREJP3",414,0)
S PSOETEC=$$PSOETEC^PSOREJP5(RX,FILL)
"RTN","PSOREJP3",415,0)
D AUDIT^PSOTRI(RX,FILL,,COM,$S(PSOETEC:"N",1:"R"),$S($G(PSOTRIC)=1:"T",$G(PSOTRIC)=2:"C",1:""))
"RTN","PSOREJP3",416,0)
Q
"RTN","PSOREJP3",417,0)
;
"RTN","PSOREJP3",418,0)
TCOM(RX,RFL) ; - Ask for TRICARE or CHAMPVA Justification
"RTN","PSOREJP3",419,0)
N COM,DIR,DIRUT,X
"RTN","PSOREJP3",420,0)
W ! S DIR(0)="F^3:100" S DIR("A")=$$ELIGDISP^PSOREJP1(RX,RFL)_" Justification" D ^DIR
"RTN","PSOREJP3",421,0)
S COM=X I $D(DIRUT) S COM="^"
"RTN","PSOREJP3",422,0)
Q COM
"RTN","PSOREJP3",423,0)
;
"RTN","PSOREJP3",424,0)
PSOET(RX,FILL) ; Returns flag for TRICARE or CHAMPVA non-billable and no claim submitted
"RTN","PSOREJP3",425,0)
; Return 1 if rejection code is eT or eC (pseudo-reject code)
"RTN","PSOREJP3",426,0)
; 0 otherwise
"RTN","PSOREJP3",427,0)
;
"RTN","PSOREJP3",428,0)
I '$G(RX) Q 0
"RTN","PSOREJP3",429,0)
N X,TRIREJCD
"RTN","PSOREJP3",430,0)
S X=0
"RTN","PSOREJP3",431,0)
S TRIREJCD=$T(TRIREJCD+1),TRIREJCD=$P(TRIREJCD,";;",2)
"RTN","PSOREJP3",432,0)
S X=$$FIND^PSOREJUT(RX,$G(FILL),,TRIREJCD,1) ; PSO*7*421 - Pass indicator to ignore ECME status
"RTN","PSOREJP3",433,0)
Q X
"RTN","PSOREJP3",434,0)
;
"RTN","PSOREJP3",435,0)
TRIREJCD ;TRICARE or CHAMPVA Reject Code, non-billable Rx ;cnf, PSO*7*358
"RTN","PSOREJP3",436,0)
;;eT,eC;;TRICARE or CHAMPVA pseudo reject codes referenced in ^PSOREJP3, ^PSOREJU4
"RTN","PSOREJP3",437,0)
Q
"RTN","PSOREJP3",438,0)
;
"RTN","PSOREJP3",439,0)
SEND(OVRCOD,CLA,PA,PSOET) ; - Sends Claim to ECME and closes Reject
"RTN","PSOREJP3",440,0)
; Input: OVRCOD - Up to three ~-pieces, and each populated would be
"RTN","PSOREJP3",441,0)
; Reason for Service Code ^ Prof Srvc Cd ^ Result of Srvc Cd
"RTN","PSOREJP3",442,0)
; CLA - Submission Clarification Code #1 ~ SCC #2 ~ SCC #3
"RTN","PSOREJP3",443,0)
; PA - Prior Auth Type ^ Prior Auth Number
"RTN","PSOREJP3",444,0)
; PSOET - 1 if eT/eC pseudo-reject on claim
"RTN","PSOREJP3",445,0)
N ALTXT,COM,DIR,PSO59,PSOCOB,PSOETEC,PSOPLAN,PSORTYPE,RESP,SMA
"RTN","PSOREJP3",446,0)
S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="YES"
"RTN","PSOREJP3",447,0)
S DIR("A",1)=" When you confirm, a new claim will be submitted for"
"RTN","PSOREJP3",448,0)
S DIR("A",2)=" the prescription and this REJECT will be marked"
"RTN","PSOREJP3",449,0)
S DIR("A",3)=" resolved."
"RTN","PSOREJP3",450,0)
S DIR("A",4)=" "
"RTN","PSOREJP3",451,0)
W ! D ^DIR K DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
"RTN","PSOREJP3",452,0)
S SMA=0 I $G(OVRCOD)]"",$G(CLA)]"",$G(PA)]"" S SMA=1
"RTN","PSOREJP3",453,0)
S ALTXT=""
"RTN","PSOREJP3",454,0)
I 'SMA D
"RTN","PSOREJP3",455,0)
. S ALTXT="REJECT WORKLIST"
"RTN","PSOREJP3",456,0)
. S:$G(OVRCOD)'="" ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$TR(OVRCOD,"^","/")_")"
"RTN","PSOREJP3",457,0)
. S:$G(CLA)]"" ALTXT=ALTXT_"-(CLARIF. CODE="_CLA_")"
"RTN","PSOREJP3",458,0)
. S:$G(PA)]"" ALTXT=ALTXT_"-(PRIOR AUTH.="_$TR(PA,"^","/")_")"
"RTN","PSOREJP3",459,0)
;
"RTN","PSOREJP3",460,0)
S PSOCOB=$$PSOCOB^PSOREJP3(RX,FILL,REJ)
"RTN","PSOREJP3",461,0)
S PSO59=$$IEN59^BPSOSRX(RX,FILL,PSOCOB)
"RTN","PSOREJP3",462,0)
S PSOPLAN=$$GETPL59^BPSPRRX5(PSO59) ; IA 6939
"RTN","PSOREJP3",463,0)
S PSORTYPE=$$GETRTP59^BPSPRRX5(PSO59) ; IA 6939
"RTN","PSOREJP3",464,0)
; Check for Tricare/Champva Non-Billable eT,eC pseudo reject set PSOETEC=1
"RTN","PSOREJP3",465,0)
S PSOETEC=""
"RTN","PSOREJP3",466,0)
I ($D(^PSRX(RX,"REJ","B","eT")))!($D(^PSRX(RX,"REJ","B","eC"))) S PSOETEC=1
"RTN","PSOREJP3",467,0)
;
"RTN","PSOREJP3",468,0)
D ECMESND^PSOBPSU1(RX,FILL,,$S($G(PSOET):"RSNB",1:"ED"),$$GETNDC^PSONDCUT(RX,FILL),,,$G(OVRCOD),,.RESP,,ALTXT,$G(CLA),$G(PA),PSOCOB,,PSOPLAN,PSORTYPE)
"RTN","PSOREJP3",469,0)
;If PSOETEC=1 RESP will exist because its a Non-Billable Rx, do not Quit continue processing
"RTN","PSOREJP3",470,0)
I PSOETEC'=1 I $G(RESP) D Q
"RTN","PSOREJP3",471,0)
. W !!?10,"Claim could not be submitted. Please try again later!"
"RTN","PSOREJP3",472,0)
. W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7) H 2
"RTN","PSOREJP3",473,0)
;
"RTN","PSOREJP3",474,0)
; Get the ePharmacy Response Pause and hang for that amount of time (default is 2 if not set)
"RTN","PSOREJP3",475,0)
N PAUSE,IEN5286
"RTN","PSOREJP3",476,0)
I $G(PSOSITE)="" N PSOSITE S PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL)
"RTN","PSOREJP3",477,0)
S IEN5286=$O(^PS(52.86,"B",+PSOSITE,""))
"RTN","PSOREJP3",478,0)
S PAUSE=$$GET1^DIQ(52.86,IEN5286_",",6)
"RTN","PSOREJP3",479,0)
I PAUSE="" S PAUSE=2
"RTN","PSOREJP3",480,0)
I PAUSE H PAUSE
"RTN","PSOREJP3",481,0)
;
"RTN","PSOREJP3",482,0)
I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL)
"RTN","PSOREJP3",483,0)
N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
"RTN","PSOREJP3",484,0)
I $$GET1^DIQ(52,RX,100,"I")=5&(PSOTRIC) D
"RTN","PSOREJP3",485,0)
. Q:$$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE"
"RTN","PSOREJP3",486,0)
. N XXX S XXX=""
"RTN","PSOREJP3",487,0)
. W !,"This prescription can be pulled early from suspense or the label will print"
"RTN","PSOREJP3",488,0)
. W !,"when PRINT FROM SUSPENSE occurs.",!
"RTN","PSOREJP3",489,0)
. R !,"Press enter to continue... ",XXX:60
"RTN","PSOREJP3",490,0)
I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
"RTN","PSOREJP3",491,0)
Q
"RTN","PSOREJP5")
0^7^B58255274
"RTN","PSOREJP5",1,0)
PSOREJP5 ;ALB/BNT - Third Party Reject Additional Reject Information Screen ;02/14/11
"RTN","PSOREJP5",2,0)
;;7.0;OUTPATIENT PHARMACY;**359,421,512,528**;DEC 1997;Build 8
"RTN","PSOREJP5",3,0)
;
"RTN","PSOREJP5",4,0)
; Reference to $$BBILL^BPSBUTL and $$RESUBMIT^BPSBUTL supported by IA 4719
"RTN","PSOREJP5",5,0)
; Reference to BPSNCPD3 supported by IA 4560
"RTN","PSOREJP5",6,0)
;
"RTN","PSOREJP5",7,0)
EN ; -- main entry point for PSO REJECT DISPLAY ADDTNL INFO
"RTN","PSOREJP5",8,0)
D EN^VALM("PSO REJECT DISPLAY ADDTNL INFO")
"RTN","PSOREJP5",9,0)
Q
"RTN","PSOREJP5",10,0)
;
"RTN","PSOREJP5",11,0)
ADDTXT ; Entry point for DUR Hidden action
"RTN","PSOREJP5",12,0)
I '$D(@(VALMAR)) Q
"RTN","PSOREJP5",13,0)
N FILL,LASTLN
"RTN","PSOREJP5",14,0)
S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
"RTN","PSOREJP5",15,0)
D FULL^VALM1
"RTN","PSOREJP5",16,0)
D EN
"RTN","PSOREJP5",17,0)
Q
"RTN","PSOREJP5",18,0)
;
"RTN","PSOREJP5",19,0)
ISDUR(RX,REJ) ;
"RTN","PSOREJP5",20,0)
; Returns 1 if there is DUR PPS RESPONSE data for the reject
"RTN","PSOREJP5",21,0)
I '$G(RX) Q 0
"RTN","PSOREJP5",22,0)
I '$G(REJ) Q 0
"RTN","PSOREJP5",23,0)
N RXCOB,DURPPS,DURIEN
"RTN","PSOREJP5",24,0)
S DURIEN=$$RESPIEN(RX,REJ)
"RTN","PSOREJP5",25,0)
Q:DURIEN="" 0
"RTN","PSOREJP5",26,0)
S RXCOB=$$RXCOB(RX,REJ)
"RTN","PSOREJP5",27,0)
I RXCOB="" S RXCOB=1
"RTN","PSOREJP5",28,0)
D DURRESP^BPSNCPD3(DURIEN,.DURPPS,RXCOB)
"RTN","PSOREJP5",29,0)
I $G(DURPPS(RXCOB,"DUR PPS RESPONSE"))!($G(DURPPS(RXCOB,"MESSAGE"))]"")!($G(DURPPS(RXCOB,"PAYER MESSAGE",1))]"") Q 1
"RTN","PSOREJP5",30,0)
Q 0
"RTN","PSOREJP5",31,0)
;
"RTN","PSOREJP5",32,0)
HDR ; -- header code
"RTN","PSOREJP5",33,0)
N LINE1,LINE2,X
"RTN","PSOREJP5",34,0)
S VALMHDR(1)=$$DVINFO^PSOREJU2(RX,FILL,1),VALMHDR(2)=$$PTINFO^PSOREJU2(RX,1)
"RTN","PSOREJP5",35,0)
;cnf, PSO*7*358, add REJ to parameter list for RXINFO^PSOREJP3
"RTN","PSOREJP5",36,0)
S VALMHDR(3)=$$RXINFO^PSOREJP3(RX,FILL,1),VALMHDR(4)=$$RXINFO^PSOREJP3(RX,FILL,2,REJ)
"RTN","PSOREJP5",37,0)
Q
"RTN","PSOREJP5",38,0)
;
"RTN","PSOREJP5",39,0)
INIT ; -- init variables and list array
"RTN","PSOREJP5",40,0)
N DATA,LINE,RXCOB,ADDREJ,NDX,I,DURIEN,X
"RTN","PSOREJP5",41,0)
F I=1:1:$G(LASTLN) D RESTORE^VALM10(I)
"RTN","PSOREJP5",42,0)
K ^TMP("PSOREJP2",$J) S VALMCNT=0,LINE=0
"RTN","PSOREJP5",43,0)
S DURIEN=$$RESPIEN(RX,REJ)
"RTN","PSOREJP5",44,0)
Q:DURIEN=""
"RTN","PSOREJP5",45,0)
S RXCOB=$$RXCOB(RX,REJ)
"RTN","PSOREJP5",46,0)
D DURRESP^BPSNCPD3(DURIEN,.ADDREJ,RXCOB)
"RTN","PSOREJP5",47,0)
I '+$G(ADDREJ(RXCOB,"DUR PPS RESPONSE")),$G(ADDREJ(RXCOB,"MESSAGE"))']"",$G(ADDREJ(RXCOB,"PAYER MESSAGE",1))="" D Q
"RTN","PSOREJP5",48,0)
. D SETLN()
"RTN","PSOREJP5",49,0)
. D SETLN("There is no additional reject information to display")
"RTN","PSOREJP5",50,0)
;
"RTN","PSOREJP5",51,0)
D SETLN()
"RTN","PSOREJP5",52,0)
D SET("MESSAGE",80-$L($$LABEL("MESSAGE")),"",ADDREJ(RXCOB,"MESSAGE"))
"RTN","PSOREJP5",53,0)
;
"RTN","PSOREJP5",54,0)
D SETLN()
"RTN","PSOREJP5",55,0)
D SET("PAYER ADDL MSG",80-$L($$LABEL("PAYER ADDL MSG")),"",$G(ADDREJ(RXCOB,"PAYER MESSAGE",1)))
"RTN","PSOREJP5",56,0)
S X="",$E(X,$L($$LABEL("PAYER ADDL MSG")))=" "
"RTN","PSOREJP5",57,0)
S I=1 F S I=$O(ADDREJ(RXCOB,"PAYER MESSAGE",I)) Q:'I D
"RTN","PSOREJP5",58,0)
. D SET("",80-$L($$LABEL("PAYER ADDL MSG")),"",X_ADDREJ(RXCOB,"PAYER MESSAGE",I))
"RTN","PSOREJP5",59,0)
;
"RTN","PSOREJP5",60,0)
S NDX=""
"RTN","PSOREJP5",61,0)
F S NDX=$O(ADDREJ(RXCOB,"DUR PPS",NDX)) Q:NDX="" D
"RTN","PSOREJP5",62,0)
. N QPF
"RTN","PSOREJP5",63,0)
. D SETLN()
"RTN","PSOREJP5",64,0)
. D SET("DUR PPS RESPONSE",80-$L($$LABEL("DUR PPS RESPONSE")),"",ADDREJ(RXCOB,"DUR PPS",NDX,"DUR PPS RESPONSE"))
"RTN","PSOREJP5",65,0)
. D SET("REASON FOR SERVICE CODE",80-$L($$LABEL("REASON FOR SERVICE CODE")),"",ADDREJ(RXCOB,"DUR PPS",NDX,"REASON FOR SERVICE CODE"))
"RTN","PSOREJP5",66,0)
. D SET("CLINICAL SIGNIFICANCE CODE",80-$L($$LABEL("CLINICAL SIGNIFICANCE CODE")),"",ADDREJ(RXCOB,"DUR PPS",NDX,"CLINICAL SIGNIFICANCE CODE"))
"RTN","PSOREJP5",67,0)
. D SET("OTHER PHARMACY INDICATOR",80-$L($$LABEL("OTHER PHARMACY INDICATOR")),"",ADDREJ(RXCOB,"DUR PPS",NDX,"OTHER PHARMACY INDICATOR"))
"RTN","PSOREJP5",68,0)
. D SET("PREVIOUS DATE OF FILL",80-$L($$LABEL("PREVIOUS DATE OF FILL")),"",ADDREJ(RXCOB,"DUR PPS",NDX,"PREVIOUS DATE OF FILL"))
"RTN","PSOREJP5",69,0)
. ;
"RTN","PSOREJP5",70,0)
. ; esg - PSO*7*421 - 2/4/13 - properly display Quantity of Previous Fill
"RTN","PSOREJP5",71,0)
. S QPF=""
"RTN","PSOREJP5",72,0)
. I ADDREJ(RXCOB,"DUR PPS",NDX,"QUANTITY OF PREVIOUS FILL") S QPF=ADDREJ(RXCOB,"DUR PPS",NDX,"QUANTITY OF PREVIOUS FILL")/1000
"RTN","PSOREJP5",73,0)
. D SET("QUANTITY OF PREVIOUS FILL",80-$L($$LABEL("QUANTITY OF PREVIOUS FILL")),"",QPF)
"RTN","PSOREJP5",74,0)
. ;
"RTN","PSOREJP5",75,0)
. D SET("DATABASE INDICATOR",80-$L($$LABEL("DATABASE INDICATOR")),"",ADDREJ(RXCOB,"DUR PPS",NDX,"DATABASE INDICATOR"))
"RTN","PSOREJP5",76,0)
. D SET("OTHER PRESCRIBER INDICATOR",80-$L($$LABEL("OTHER PRESCRIBER INDICATOR")),"",ADDREJ(RXCOB,"DUR PPS",NDX,"OTHER PRESCRIBER INDICATOR"))
"RTN","PSOREJP5",77,0)
. D SET("DUR FREE TEXT MESSAGE",80-$L($$LABEL("DUR FREE TEXT MESSAGE")),"",ADDREJ(RXCOB,"DUR PPS",NDX,"DUR FREE TEXT MESSAGE"))
"RTN","PSOREJP5",78,0)
. D SET("DUR ADDITIONAL TEXT",80-$L($$LABEL("DUR ADDITIONAL TEXT")),"",ADDREJ(RXCOB,"DUR PPS",NDX,"DUR ADDITIONAL TEXT"))
"RTN","PSOREJP5",79,0)
S VALMCNT=LINE
"RTN","PSOREJP5",80,0)
Q
"RTN","PSOREJP5",81,0)
;
"RTN","PSOREJP5",82,0)
LABEL(FIELD) ; Sets the label for the field
"RTN","PSOREJP5",83,0)
I FIELD="MESSAGE" Q "Payer Msg: "
"RTN","PSOREJP5",84,0)
I FIELD="PAYER ADDL MSG" Q "Payer Addl Msg: "
"RTN","PSOREJP5",85,0)
I FIELD="DUR PPS RESPONSE" Q "DUR Response: "
"RTN","PSOREJP5",86,0)
I FIELD="REASON FOR SERVICE CODE" Q "Reason Code: "
"RTN","PSOREJP5",87,0)
I FIELD="CLINICAL SIGNIFICANCE CODE" Q "Clinical Significance Code: "
"RTN","PSOREJP5",88,0)
I FIELD="OTHER PHARMACY INDICATOR" Q "Other Pharmacy Indicator: "
"RTN","PSOREJP5",89,0)
I FIELD="PREVIOUS DATE OF FILL" Q "Previous Date of Fill: "
"RTN","PSOREJP5",90,0)
I FIELD="QUANTITY OF PREVIOUS FILL" Q "Quantity of Previous Fill: "
"RTN","PSOREJP5",91,0)
I FIELD="DATABASE INDICATOR" Q "Database Indicator: "
"RTN","PSOREJP5",92,0)
I FIELD="OTHER PRESCRIBER INDICATOR" Q "Other Prescriber Indicator: "
"RTN","PSOREJP5",93,0)
I FIELD="DUR FREE TEXT MESSAGE" Q "DUR Text: "
"RTN","PSOREJP5",94,0)
I FIELD="DUR ADDITIONAL TEXT" Q "DUR Add Text: "
"RTN","PSOREJP5",95,0)
Q ""
"RTN","PSOREJP5",96,0)
;
"RTN","PSOREJP5",97,0)
SET(FIELD,L,UND,TXT) ; Sets the lines for fields that require text wrapping
"RTN","PSOREJP5",98,0)
N I,T
"RTN","PSOREJP5",99,0)
I $L(TXT)'>L D SETLN($$LABEL(FIELD)_TXT,,$S($G(UND):1,1:0),80-L) Q
"RTN","PSOREJP5",100,0)
F I=1:1 Q:TXT="" D
"RTN","PSOREJP5",101,0)
. I I=1 D SETLN($$LABEL(FIELD)_$E(TXT,1,L),,,80-L) S TXT=$E(TXT,L+1,999) Q
"RTN","PSOREJP5",102,0)
. S T="",$E(T,81-L)=$E(TXT,1,L) D SETLN(T,,$S($E(TXT,L+1,999)=""&$G(UND):1,1:0),80-L) S TXT=$E(TXT,L+1,999)
"RTN","PSOREJP5",103,0)
Q
"RTN","PSOREJP5",104,0)
;
"RTN","PSOREJP5",105,0)
SETLN(TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section
"RTN","PSOREJP5",106,0)
N X
"RTN","PSOREJP5",107,0)
S:$G(TEXT)="" $E(TEXT,80)=""
"RTN","PSOREJP5",108,0)
S:$L(TEXT)>80 TEXT=$E(TEXT,1,80)
"RTN","PSOREJP5",109,0)
S LINE=LINE+1,^TMP("PSOREJP2",$J,LINE,0)=$G(TEXT)
"RTN","PSOREJP5",110,0)
;
"RTN","PSOREJP5",111,0)
I LINE>$G(LASTLN) D SAVE^VALM10(LINE) S LASTLN=LINE
"RTN","PSOREJP5",112,0)
;
"RTN","PSOREJP5",113,0)
I $G(REV) D Q
"RTN","PSOREJP5",114,0)
. D CNTRL^VALM10(LINE,1,$L(TEXT),IORVON,IOINORM)
"RTN","PSOREJP5",115,0)
. I $G(UND) D CNTRL^VALM10(LINE,$L(TEXT)+1,80,IOUON,IOINORM)
"RTN","PSOREJP5",116,0)
I $G(UND) D CNTRL^VALM10(LINE,1,80,IOUON,IOINORM)
"RTN","PSOREJP5",117,0)
I $G(HIG) D
"RTN","PSOREJP5",118,0)
. D CNTRL^VALM10(LINE,HIG,80,IOINHI_$S($G(UND):IOUON,1:""),IOINORM)
"RTN","PSOREJP5",119,0)
Q
"RTN","PSOREJP5",120,0)
;
"RTN","PSOREJP5",121,0)
RXCOB(RX,REJ) ; Return the COB Indicator for the reject
"RTN","PSOREJP5",122,0)
; Input: RX = RX IEN
"RTN","PSOREJP5",123,0)
; REJ = Reject Info multiple IEN
"RTN","PSOREJP5",124,0)
I '$G(RX) Q ""
"RTN","PSOREJP5",125,0)
I '$G(REJ) Q ""
"RTN","PSOREJP5",126,0)
N RXCOB
"RTN","PSOREJP5",127,0)
S RXCOB=$$GET1^DIQ(52.25,REJ_","_RX_",","27","I")
"RTN","PSOREJP5",128,0)
Q $S(+RXCOB>1:RXCOB,1:1)
"RTN","PSOREJP5",129,0)
;
"RTN","PSOREJP5",130,0)
RESPIEN(RX,REJ) ; Return the RESPONSE ID from the Reject Info multiple
"RTN","PSOREJP5",131,0)
; Input: RX = RX IEN
"RTN","PSOREJP5",132,0)
; REJ = Reject Info multiple IEN
"RTN","PSOREJP5",133,0)
I '$G(RX) Q ""
"RTN","PSOREJP5",134,0)
I '$G(REJ) Q ""
"RTN","PSOREJP5",135,0)
Q $$GET1^DIQ(52.25,REJ_","_RX_",","16","I")
"RTN","PSOREJP5",136,0)
;
"RTN","PSOREJP5",137,0)
HELP ; -- help code
"RTN","PSOREJP5",138,0)
S X="?" D DISP^XQORM1 W !!
"RTN","PSOREJP5",139,0)
Q
"RTN","PSOREJP5",140,0)
;
"RTN","PSOREJP5",141,0)
EXIT ; -- exit code
"RTN","PSOREJP5",142,0)
Q
"RTN","PSOREJP5",143,0)
;
"RTN","PSOREJP5",144,0)
EXPND ; -- expand code
"RTN","PSOREJP5",145,0)
Q
"RTN","PSOREJP5",146,0)
;
"RTN","PSOREJP5",147,0)
REJ ; - DUR Information - called from REJ^PSOREJP1
"RTN","PSOREJP5",148,0)
; this code moved from PSOREJP1, routine was too large
"RTN","PSOREJP5",149,0)
;
"RTN","PSOREJP5",150,0)
S PSONAF=$$NFLDT^BPSBUTL(RX,FILL) ; IA 4719
"RTN","PSOREJP5",151,0)
I PSONAF'="" D SETLN^PSOREJP1("Next Avail Fill: "_$$FMTE^XLFDT(PSONAF),,,16) ; PSO*7*421
"RTN","PSOREJP5",152,0)
S PSOADD=$$ADDFLDS^BPSBUTL(RX,FILL,PSOCOB) ; IA 4719
"RTN","PSOREJP5",153,0)
I $P(PSOADD,U)'="" D SETLN^PSOREJP1("Maximum Age Qualifier: "_$P(PSOADD,U),,,22)
"RTN","PSOREJP5",154,0)
I $P(PSOADD,U,2)'="" D SETLN^PSOREJP1("Maximum Age: "_$P(PSOADD,U,2),,,12)
"RTN","PSOREJP5",155,0)
I $P(PSOADD,U,3)'="" D SETLN^PSOREJP1("Maximum Amount: "_$P(PSOADD,U,3),,,15)
"RTN","PSOREJP5",156,0)
I $P(PSOADD,U,4)'="" D SETLN^PSOREJP1("Maximum Amount Qualifier: "_$P(PSOADD,U,4),,,25)
"RTN","PSOREJP5",157,0)
I $P(PSOADD,U,5)'="" D SETLN^PSOREJP1("Maximum Amount Time Period: "_$P(PSOADD,U,5),,,27)
"RTN","PSOREJP5",158,0)
I $P(PSOADD,U,6)'="" D SETLN^PSOREJP1("Maximum Amount Time Period Start Date: "_$$FMTE^XLFDT($P(PSOADD,U,6)),,,38)
"RTN","PSOREJP5",159,0)
I $P(PSOADD,U,7)'="" D SETLN^PSOREJP1("Maximum Amount Time Period End Date: "_$$FMTE^XLFDT($P(PSOADD,U,7)),,,36)
"RTN","PSOREJP5",160,0)
I $P(PSOADD,U,8)'="" D SETLN^PSOREJP1("Maximum Amount Time Period Units: "_$P(PSOADD,U,8),,,33)
"RTN","PSOREJP5",161,0)
I $P(PSOADD,U,9)'="" D SETLN^PSOREJP1("Minimum Age Qualifier: "_$P(PSOADD,U,9),,,22)
"RTN","PSOREJP5",162,0)
I $P(PSOADD,U,10)'="" D SETLN^PSOREJP1("Minimum Age: "_$P(PSOADD,U,10),,,12)
"RTN","PSOREJP5",163,0)
I $P(PSOADD,U,11)'="" D SETLN^PSOREJP1("Minimum Amount: "_$P(PSOADD,U,11),,,15)
"RTN","PSOREJP5",164,0)
I $P(PSOADD,U,12)'="" D SETLN^PSOREJP1("Minimum Amount Qualifier: "_$P(PSOADD,U,12),,,25)
"RTN","PSOREJP5",165,0)
I $P(PSOADD,U,13)'="" D SETLN^PSOREJP1("Remaining Amount: "_$P(PSOADD,U,13),,,17)
"RTN","PSOREJP5",166,0)
I $P(PSOADD,U,14)'="" D SETLN^PSOREJP1("Remaining Amount Qualifier: "_$P(PSOADD,U,14),,,27)
"RTN","PSOREJP5",167,0)
;
"RTN","PSOREJP5",168,0)
D SET^PSOREJP1("PAYER MESSAGE",63)
"RTN","PSOREJP5",169,0)
D SET^PSOREJP1("REASON",63)
"RTN","PSOREJP5",170,0)
S PFLDT=$$FMTE^XLFDT($G(DATA(REJ,"PLAN PREVIOUS FILL DATE")))
"RTN","PSOREJP5",171,0)
D SET^PSOREJP1("DUR TEXT",63,$S(PFLDT="":1,1:0))
"RTN","PSOREJP5",172,0)
I PFLDT'="" D SETLN^PSOREJP1("Last Fill Date : "_PFLDT_" (from payer)",,1,18)
"RTN","PSOREJP5",173,0)
Q
"RTN","PSOREJP5",174,0)
;
"RTN","PSOREJP5",175,0)
PSOETEC(RX,FILL) ; Returns flag for TRICARE or CHAMPVA non-billable claims
"RTN","PSOREJP5",176,0)
;This function is used to determine how a claim is stored in the PSO AUDIT LOG (file #56.87),
"RTN","PSOREJP5",177,0)
;it is not necessary to check to see if the claim has a reject that is resolved or unresolved
"RTN","PSOREJP5",178,0)
; Returns: 1 - if rejection code is eT or eC (pseudo-reject code) / 0 - otherwise
"RTN","PSOREJP5",179,0)
I '$G(RX) Q 0
"RTN","PSOREJP5",180,0)
I $D(^PSRX(RX,"REJ","B","eT")) Q 1
"RTN","PSOREJP5",181,0)
I $D(^PSRX(RX,"REJ","B","eC")) Q 1
"RTN","PSOREJP5",182,0)
Q 0
"RTN","PSOREJP5",183,0)
;
"RTN","PSOREJU3")
0^8^B153391658
"RTN","PSOREJU3",1,0)
PSOREJU3 ;BIRM/LJE - BPS (ECME) - Clinical Rejects Utilities (3) ;04/25/08
"RTN","PSOREJU3",2,0)
;;7.0;OUTPATIENT PHARMACY;**287,290,358,359,385,421,427,448,478,513,482,528**;DEC 1997;Build 8
"RTN","PSOREJU3",3,0)
;References to 9002313.99 supported by IA 4305
"RTN","PSOREJU3",4,0)
;Reference to $$CLAIM^BPSBUTL supported by IA 4719
"RTN","PSOREJU3",5,0)
;Reference to LOG^BPSOSL supported by ICR# 6764
"RTN","PSOREJU3",6,0)
;Reference to IEN59^BPSOSRX supported by ICR# 4412
"RTN","PSOREJU3",7,0)
;
"RTN","PSOREJU3",8,0)
Q
"RTN","PSOREJU3",9,0)
;
"RTN","PSOREJU3",10,0)
TRICCHK(RX,RFL,RESP,FROM,RVTX) ;check to see if Rx is non-billable or in an "In Progress" state on ECME
"RTN","PSOREJU3",11,0)
; Input: (r) RX - Rx IEN (#52)
"RTN","PSOREJU3",12,0)
; (r) RFL - REFILL
"RTN","PSOREJU3",13,0)
; (o) RESP - Response from $$EN^BPSNCPDP api
"RTN","PSOREJU3",14,0)
; TRICCHK assumes that the calling routine has validated that the fill is TRICARE or CHAMPVA.
"RTN","PSOREJU3",15,0)
;
"RTN","PSOREJU3",16,0)
; - \Need to be mindful of foreground and background processing.
"RTN","PSOREJU3",17,0)
;
"RTN","PSOREJU3",18,0)
N ESTAT,ETOUT,NFROM,PSOBEI
"RTN","PSOREJU3",19,0)
I '$D(FROM) S FROM=""
"RTN","PSOREJU3",20,0)
S ESTAT=$P(RESP,"^",4)
"RTN","PSOREJU3",21,0)
S NFROM=0
"RTN","PSOREJU3",22,0)
I FROM="PL"!(FROM="PC") S NFROM=1
"RTN","PSOREJU3",23,0)
Q:ESTAT["PAYABLE"!(ESTAT["REJECTED")
"RTN","PSOREJU3",24,0)
S PSOBEI=$$ELIGDISP^PSOREJP1(RX,RFL)
"RTN","PSOREJU3",25,0)
;
"RTN","PSOREJU3",26,0)
D LOG^BPSOSL($$IEN59^BPSOSRX(RX,RFL),$T(+0)_"-TRICCHK, RESP="_RESP) ; ICR#s 4412,6764
"RTN","PSOREJU3",27,0)
I ESTAT["IN PROGRESS",FROM="PC" D LOG^BPSOSL($$IEN59^BPSOSRX(RX,RFL),$T(+0)_"-Would have noted in Activity Log that Rx was left in CMOP suspense") Q ; ICR#s 4412,6764
"RTN","PSOREJU3",28,0)
;
"RTN","PSOREJU3",29,0)
I ESTAT["IN PROGRESS",FROM="RRL"!($G(RVTX)="RX RELEASE-NDC CHANGE") D Q
"RTN","PSOREJU3",30,0)
. I 'NFROM D
"RTN","PSOREJU3",31,0)
. . W !!,PSOBEI_" Prescription "_$$GET1^DIQ(52,RX,".01")_" cannot be released until ECME 'IN PROGRESS'"
"RTN","PSOREJU3",32,0)
. . W !,"status is resolved payable.",!!
"RTN","PSOREJU3",33,0)
;
"RTN","PSOREJU3",34,0)
I $D(RESP) D Q
"RTN","PSOREJU3",35,0)
. I +RESP=6 W:'NFROM&('$G(CMOP)) !!,"Inactive ECME "_PSOBEI,!! D Q
"RTN","PSOREJU3",36,0)
. . S ACT="Inactive ECME "_PSOBEI D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ)
"RTN","PSOREJU3",37,0)
. I +RESP=2!(+RESP=3) N PSONBILL S PSONBILL=1 D TRIC2 Q
"RTN","PSOREJU3",38,0)
. I +RESP=4!(ESTAT["IN PROGRESS") N PSONPROG S PSONPROG=1 D TRIC2 Q
"RTN","PSOREJU3",39,0)
Q
"RTN","PSOREJU3",40,0)
;
"RTN","PSOREJU3",41,0)
TRIC2 ;
"RTN","PSOREJU3",42,0)
N ACTION,DA,DIR,DIRUT,PSCAN,PSOIT,PSORESP,PSOTRIC
"RTN","PSOREJU3",43,0)
N REA,REJ,REJCOD,REJDATA,X,ZZZ
"RTN","PSOREJU3",44,0)
S PSOTRIC=1,REJ=9999999999
"RTN","PSOREJU3",45,0)
I $G(CMOP)&($G(PSONPROG)) D TACT Q
"RTN","PSOREJU3",46,0)
;
"RTN","PSOREJU3",47,0)
; If the prescription is non-billable, put the eT/eC reject on the
"RTN","PSOREJU3",48,0)
; Prescription (WRKLST^PSOREJU4), then determine the reject number.
"RTN","PSOREJU3",49,0)
;
"RTN","PSOREJU3",50,0)
I +RESP=2 D
"RTN","PSOREJU3",51,0)
. D WRKLST^PSOREJU4(RX,RFL,,DUZ,DT,1,"",RESP)
"RTN","PSOREJU3",52,0)
. S X=$$FIND^PSOREJUT(RX,RFL,.REJDATA,"eT,eC",1)
"RTN","PSOREJU3",53,0)
. S REJ=0
"RTN","PSOREJU3",54,0)
. F S REJ=$O(REJDATA(REJ)) Q:'REJ I "eT,eC"[REJDATA(REJ,"CODE") Q
"RTN","PSOREJU3",55,0)
. Q
"RTN","PSOREJU3",56,0)
;
"RTN","PSOREJU3",57,0)
Q:$G(CMOP)
"RTN","PSOREJU3",58,0)
I 'NFROM D DISPLAY(RX,REJ)
"RTN","PSOREJU3",59,0)
I 'NFROM&($G(PSONPROG)) D D SUSP Q
"RTN","PSOREJU3",60,0)
. W !!,"This prescription will be suspended. After the third party claim is resolved,"
"RTN","PSOREJU3",61,0)
. W !,"it may be printed or pulled early from suspense.",!
"RTN","PSOREJU3",62,0)
. R !!,"Press <RETURN> to continue...",ZZZ:60,!
"RTN","PSOREJU3",63,0)
I NFROM&($G(PSONPROG)) D TACT Q
"RTN","PSOREJU3",64,0)
Q:NFROM
"RTN","PSOREJU3",65,0)
TRIC3 ;
"RTN","PSOREJU3",66,0)
D MSG
"RTN","PSOREJU3",67,0)
I FROM="PL"!(FROM="PC") D SUSP Q
"RTN","PSOREJU3",68,0)
;cnf, PSO*7*358, add code for options
"RTN","PSOREJU3",69,0)
N ACTION,COM,DEF,DIR,DIRUT,OPTS
"RTN","PSOREJU3",70,0)
TRIC4 S DIR(0)="SO^",DIR("A")="",OPTS="DQ",DEF="D"
"RTN","PSOREJU3",71,0)
S PSORESP=$P($G(RESP),U,2)
"RTN","PSOREJU3",72,0)
I PSORESP["NO ACTIVE/VALID ROI" S DEF="Q" ;IB routine IBNCPDP1 contains this text.
"RTN","PSOREJU3",73,0)
;reference to ^XUSEC( supported by IA 10076
"RTN","PSOREJU3",74,0)
I $D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S OPTS=OPTS_"I" ;PSO*7.0*358, if user has security key, include IGNORE in TRICARE/CHAMPVA options
"RTN","PSOREJU3",75,0)
S:(OPTS["D") DIR(0)=DIR(0)_"D:(D)iscontinue - DO NOT FILL PRESCRIPTION;",DIR("A")=DIR("A")_"(D)iscontinue,"
"RTN","PSOREJU3",76,0)
S:(OPTS["Q") DIR(0)=DIR(0)_"Q:(Q)UIT - SEND TO WORKLIST (REQUIRES INTERVENTION);",DIR("A")=DIR("A")_"(Q)uit,"
"RTN","PSOREJU3",77,0)
S:(OPTS["I") DIR(0)=DIR(0)_"I:(I)GNORE - FILL Rx WITHOUT CLAIM SUBMISSION;",DIR("A")=DIR("A")_"(I)gnore,"
"RTN","PSOREJU3",78,0)
S $E(DIR(0),$L(DIR(0)))="",$E(DIR("A"),$L(DIR("A")))="",DIR("??")="^D HELP^PSOREJU2("""_OPTS_""")"
"RTN","PSOREJU3",79,0)
S:$G(DEF)'="" DIR("B")=DEF D ^DIR I $D(DIRUT) S Y="Q" W !
"RTN","PSOREJU3",80,0)
;
"RTN","PSOREJU3",81,0)
S ACTION=Y
"RTN","PSOREJU3",82,0)
I ACTION="D" S ACTION=$$DC^PSOREJU1(RX,ACTION) ;cnf, PSO*7*358
"RTN","PSOREJU3",83,0)
S PSOIT=""
"RTN","PSOREJU3",84,0)
I ACTION="I" S PSOIT=$$IGNORE^PSOREJU1(RX,RFL)
"RTN","PSOREJU3",85,0)
I $P(PSOIT,"^")=0 D G TRIC4
"RTN","PSOREJU3",86,0)
. I $P(PSOIT,"^",2)'="" D
"RTN","PSOREJU3",87,0)
. . W $C(7),!,"Gross Amount Due is $"_$P(PSOIT,"^",2)_". IGNORE requires EPHARMACY SITE MANAGER key."
"RTN","PSOREJU3",88,0)
I ACTION="I" G TRIC4:'$$CONT^PSOREJU1() S COM=$$TCOM^PSOREJP3(RX,RFL) G TRIC4:COM="^" G TRIC4:'$$SIG^PSOREJU1() D
"RTN","PSOREJU3",89,0)
. D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,COM,"","","","","",1) ;TRICARE/CHAMPVA non-billable should have only 1 reject - eT/eC
"RTN","PSOREJU3",90,0)
. D AUDIT^PSOTRI(RX,RFL,,COM,$S($$PSOETEC^PSOREJP5(RX,RFL):"N",1:"R"),$P(RESP,"^",3))
"RTN","PSOREJU3",91,0)
Q
"RTN","PSOREJU3",92,0)
;
"RTN","PSOREJU3",93,0)
MSG ;
"RTN","PSOREJU3",94,0)
W !!,"This is a non-billable "_$$ELIGDISP^PSOREJP1(RX,RFL)_" prescription." ;cnf, PSO*7*358
"RTN","PSOREJU3",95,0)
Q
"RTN","PSOREJU3",96,0)
SUSP ;Suspense Rx due to IN PROGRESS status in ECME
"RTN","PSOREJU3",97,0)
N DA,ACT,RX0,SD,RXS,PSOWFLG,DIK,RXN,XFLAG,RXP,DD,DO,X,Y,DIC,VALMSG,COMM,LFD,DFLG,RXCMOP
"RTN","PSOREJU3",98,0)
N PSOQFLAG,PSORXZD,PSOQFLAG,PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP
"RTN","PSOREJU3",99,0)
S DA=RX D SUS^PSORXL1
"RTN","PSOREJU3",100,0)
TACT ;
"RTN","PSOREJU3",101,0)
S ACT=$$ELIGDISP^PSOREJP1(RX,RFL)_"-Rx placed on Suspense due to"_$S($G(PSONPROG):" ECME IN PROGRESS status",$G(PSONBILL):"the Rx being Non-billable",1:"")
"RTN","PSOREJU3",102,0)
I '$G(DUZ) N DUZ S DUZ=.5
"RTN","PSOREJU3",103,0)
D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ)
"RTN","PSOREJU3",104,0)
Q
"RTN","PSOREJU3",105,0)
;
"RTN","PSOREJU3",106,0)
DISPLAY(RX,REJ,KEY,RRR) ; - Displays REJECT information
"RTN","PSOREJU3",107,0)
; Input: (r) RX - Rx IEN (#52)
"RTN","PSOREJU3",108,0)
; (r) REJ - REJECT ID (IEN)
"RTN","PSOREJU3",109,0)
; (o) KEY - Display "Press any KEY to continue..." (1-YES/0-NO) (Default: 0)
"RTN","PSOREJU3",110,0)
; (o) RRR - Reject Resolution Required information Flag(0/1)^Threshold Amt^Gross Amt Due (Default: 0)
"RTN","PSOREJU3",111,0)
; If Flag = 0, there is no Reject Resolution Required reject code. Parameter added with PSO*421
"RTN","PSOREJU3",112,0)
;
"RTN","PSOREJU3",113,0)
Q:$G(NFROM)
"RTN","PSOREJU3",114,0)
I '$G(RX)!'$G(REJ) Q
"RTN","PSOREJU3",115,0)
I '$D(^PSRX(RX,"REJ",REJ))&('$G(PSONBILL))&('$G(PSONPROG)) Q
"RTN","PSOREJU3",116,0)
;
"RTN","PSOREJU3",117,0)
N DATA,RFL,LINE,%
"RTN","PSOREJU3",118,0)
S RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
"RTN","PSOREJU3",119,0)
I '$G(PSONBILL)&('$G(PSONPROG)) D GET^PSOREJU2(RX,RFL,.DATA,REJ) I '$D(DATA(REJ)) Q
"RTN","PSOREJU3",120,0)
;
"RTN","PSOREJU3",121,0)
D HDR
"RTN","PSOREJU3",122,0)
S $P(LINE,"-",74)="" W !?3,LINE
"RTN","PSOREJU3",123,0)
W !?3,$$DVINFO(RX,RFL)
"RTN","PSOREJU3",124,0)
W !?3,$$PTINFO^PSOREJU2(RX)
"RTN","PSOREJU3",125,0)
W !?3,"Rx/Drug : ",$$GET1^DIQ(52,RX,.01),"/",RFL," - ",$E($$GET1^DIQ(52,RX,6),1,20),?54
"RTN","PSOREJU3",126,0)
W:'$G(PSONBILL)&('$G(PSONPROG)) "ECME#: ",$P($$CLAIM^BPSBUTL(RX,RFL),U,6)
"RTN","PSOREJU3",127,0)
D TYPE G DISP2:$G(PSONBILL)!($G(PSONPROG))
"RTN","PSOREJU3",128,0)
I $G(DATA(REJ,"PAYER MESSAGE"))'="" W !?3,"Payer Message: " D PRT^PSOREJU2("PAYER MESSAGE",18,58)
"RTN","PSOREJU3",129,0)
I $G(DATA(REJ,"DUR TEXT"))'="" W !?3,"DUR Text : ",DATA(REJ,"DUR TEXT")
"RTN","PSOREJU3",130,0)
W !?3,"Insurance : ",DATA(REJ,"INSURANCE NAME"),?50,"Contact: ",DATA(REJ,"PLAN CONTACT")
"RTN","PSOREJU3",131,0)
W !?3,"Group Name : ",$E(DATA(REJ,"GROUP NAME"),1,26)
"RTN","PSOREJU3",132,0)
W ?45,"Group Number: ",$E(DATA(REJ,"GROUP NUMBER"),1,15)
"RTN","PSOREJU3",133,0)
I $G(DATA(REJ,"CARDHOLDER ID"))'="" W !?3,"Cardholder ID: ",$E(DATA(REJ,"CARDHOLDER ID"),1,20)
"RTN","PSOREJU3",134,0)
I DATA(REJ,"PLAN PREVIOUS FILL DATE")'="" D
"RTN","PSOREJU3",135,0)
. W !?3,"Last Fill Dt.: ",DATA(REJ,"PLAN PREVIOUS FILL DATE")
"RTN","PSOREJU3",136,0)
. W:DATA(REJ,"PLAN PREVIOUS FILL DATE")'="" " (from payer)"
"RTN","PSOREJU3",137,0)
;
"RTN","PSOREJU3",138,0)
N PSOAR,PSOCNT,PSOCOMMENT,PSODATA,PSODATE,PSODATE1
"RTN","PSOREJU3",139,0)
N PSODFN,PSOPC,PSOSTATUS,PSOSTR,PSOUSER
"RTN","PSOREJU3",140,0)
;
"RTN","PSOREJU3",141,0)
; Get Patient ID
"RTN","PSOREJU3",142,0)
S PSODFN=$$GET1^DIQ(52,RX,2,"I")
"RTN","PSOREJU3",143,0)
;
"RTN","PSOREJU3",144,0)
; Loop through Patient Comments - Add ACTIVE Comments to PSOAR array
"RTN","PSOREJU3",145,0)
S PSODATE=""
"RTN","PSOREJU3",146,0)
S PSOCNT=0
"RTN","PSOREJU3",147,0)
K PSOAR
"RTN","PSOREJU3",148,0)
F S PSODATE=$O(^PS(55,PSODFN,"PC","B",PSODATE)) Q:PSODATE="" D
"RTN","PSOREJU3",149,0)
. S PSOPC=""
"RTN","PSOREJU3",150,0)
. F S PSOPC=$O(^PS(55,PSODFN,"PC","B",PSODATE,PSOPC)) Q:PSOPC="" D
"RTN","PSOREJU3",151,0)
. . K PSODATA
"RTN","PSOREJU3",152,0)
. . D GETS^DIQ(55.17,PSOPC_","_PSODFN_",",".01;1;2;3","IE","PSODATA")
"RTN","PSOREJU3",153,0)
. . ;
"RTN","PSOREJU3",154,0)
. . ; Only display ACTIVE Patient Comments
"RTN","PSOREJU3",155,0)
. . S PSOSTATUS=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",2,"I"))
"RTN","PSOREJU3",156,0)
. . I PSOSTATUS'="Y" Q
"RTN","PSOREJU3",157,0)
. . ;
"RTN","PSOREJU3",158,0)
. . S PSODATE1=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",.01,"E"))
"RTN","PSOREJU3",159,0)
. . S PSOUSER=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",1,"E"))
"RTN","PSOREJU3",160,0)
. . S PSOCOMMENT=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",3,"E"))
"RTN","PSOREJU3",161,0)
. . S PSOSTR=PSODATE1_" - "_PSOCOMMENT_" ("_PSOUSER_")"
"RTN","PSOREJU3",162,0)
. . S PSOCNT=PSOCNT+1
"RTN","PSOREJU3",163,0)
. . S PSOAR(PSOCNT)=PSOSTR
"RTN","PSOREJU3",164,0)
;
"RTN","PSOREJU3",165,0)
; If PSOAR array exists, display Active Patient Comments
"RTN","PSOREJU3",166,0)
I $D(PSOAR) D
"RTN","PSOREJU3",167,0)
. W !?3,"Patient Billing Comment(s):"
"RTN","PSOREJU3",168,0)
. ;
"RTN","PSOREJU3",169,0)
. ; Loop through PSOAR in reverse order to display Patient
"RTN","PSOREJU3",170,0)
. ; Comments in reverse chronological order
"RTN","PSOREJU3",171,0)
. S PSOCNT=""
"RTN","PSOREJU3",172,0)
. F S PSOCNT=$O(PSOAR(PSOCNT),-1) Q:PSOCNT="" D
"RTN","PSOREJU3",173,0)
. . ;
"RTN","PSOREJU3",174,0)
. . ; Use ^DIWP to display Patient Comments with proper
"RTN","PSOREJU3",175,0)
. . ; line breaking
"RTN","PSOREJU3",176,0)
. . N %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z
"RTN","PSOREJU3",177,0)
. . K ^UTILITY($J,"W")
"RTN","PSOREJU3",178,0)
. . S X=PSOAR(PSOCNT)
"RTN","PSOREJU3",179,0)
. . S DIWL=1
"RTN","PSOREJU3",180,0)
. . S DIWR=78
"RTN","PSOREJU3",181,0)
. . D ^DIWP
"RTN","PSOREJU3",182,0)
. . ;
"RTN","PSOREJU3",183,0)
. . S PSOLAST=0
"RTN","PSOREJU3",184,0)
. . F PSOY=1:1 Q:('$D(^UTILITY($J,"W",1,PSOY,0))) D
"RTN","PSOREJU3",185,0)
. . . S PSOCOM=$G(^UTILITY($J,"W",1,PSOY,0))
"RTN","PSOREJU3",186,0)
. . . W !?3,PSOCOM
"RTN","PSOREJU3",187,0)
. K ^UTILITY($J,"W")
"RTN","PSOREJU3",188,0)
;
"RTN","PSOREJU3",189,0)
I $G(RRR) D ;added with PSO*421
"RTN","PSOREJU3",190,0)
. W !!?3,"Reject Resolution Required"
"RTN","PSOREJU3",191,0)
. W !?3,"Gross Amount Due ($"_$J($P(RRR,U,3)*100\1/100,0,2)_") is greater than or equal to"
"RTN","PSOREJU3",192,0)
. W !?3,"Threshold Dollar Amount ($"_$P(RRR,U,2)_")"
"RTN","PSOREJU3",193,0)
. W !?3,"Please select Quit to resolve this reject on the Reject Worklist."
"RTN","PSOREJU3",194,0)
DISP2 ;
"RTN","PSOREJU3",195,0)
W !?3,LINE,$C(7) I $G(KEY) W !?3,"Press <RETURN> to continue..." R %:DTIME W !
"RTN","PSOREJU3",196,0)
Q
"RTN","PSOREJU3",197,0)
;
"RTN","PSOREJU3",198,0)
TYPE ;
"RTN","PSOREJU3",199,0)
I $G(PSONBILL)!($G(PSONPROG)) D Q
"RTN","PSOREJU3",200,0)
. D NOW^%DTC S Y=% D DD^%DT
"RTN","PSOREJU3",201,0)
. W !?3,"Date/Time: "_$$FMTE^XLFDT(Y)
"RTN","PSOREJU3",202,0)
. W !?3,"Reason : ",$S($G(PSONBILL):"Drug not billable.",$G(PSONPROG):"ECME Status is in an 'IN PROGRESS' state and cannot be filled",1:"")
"RTN","PSOREJU3",203,0)
;
"RTN","PSOREJU3",204,0)
I $G(DATA(REJ,"REASON"))'="" W !?3,"Reason : " D PRT^PSOREJU2("REASON",14,62)
"RTN","PSOREJU3",205,0)
N RTXT,OCODE,OTXT,I
"RTN","PSOREJU3",206,0)
S (OTXT,RTXT,OCODE)="",RTXT=$S(DATA(REJ,"CODE")=79:"REFILL TOO SOON",DATA(REJ,"CODE")=88:"DUR REJECT",1:$$EXP^PSOREJP1(DATA(REJ,"CODE")))_" ("_DATA(REJ,"CODE")_")"
"RTN","PSOREJU3",207,0)
F I=1:1 S OCODE=$P(DATA(REJ,"OTHER REJECTS"),",",I) Q:OCODE="" D
"RTN","PSOREJU3",208,0)
. S OTXT=OTXT_", "_$S(OCODE=79:"REFILL TOO SOON",OCODE=88:"DUR REJECT",1:$$EXP^PSOREJP1(OCODE))_" ("_OCODE_")"
"RTN","PSOREJU3",209,0)
S RTXT=RTXT_OTXT_". Received on "_$$FMTE^XLFDT($G(DATA(REJ,"DATE/TIME")))_"."
"RTN","PSOREJU3",210,0)
S OTXT=""
"RTN","PSOREJU3",211,0)
W !?3,"Reject(s): " D WRAP(RTXT,14)
"RTN","PSOREJU3",212,0)
Q
"RTN","PSOREJU3",213,0)
;
"RTN","PSOREJU3",214,0)
WRAP(PSOTXT,INDENT) ;
"RTN","PSOREJU3",215,0)
N I,K,PSOWRAP,PSOMARG
"RTN","PSOREJU3",216,0)
S PSOWRAP=1,PSOMARG=$S('$G(PSORM):80,$D(IOM):IOM,1:80)-(INDENT+5)
"RTN","PSOREJU3",217,0)
W1 S:$L(PSOTXT)<PSOMARG PSOWRAP(PSOWRAP)=PSOTXT I $L(PSOTXT)'<PSOMARG F I=PSOMARG:-1:0 I $E(PSOTXT,I)?1P S PSOWRAP(PSOWRAP)=$E(PSOTXT,1,I),PSOTXT=$E(PSOTXT,I+1,999),PSOWRAP=PSOWRAP+1 G W1
"RTN","PSOREJU3",218,0)
F K=1:1:PSOWRAP W ?INDENT,PSOWRAP(K),!
"RTN","PSOREJU3",219,0)
Q
"RTN","PSOREJU3",220,0)
;
"RTN","PSOREJU3",221,0)
HDR ; Display the reject notification screen header
"RTN","PSOREJU3",222,0)
N ELDSP,TAB
"RTN","PSOREJU3",223,0)
S ELDSP=$$ELIGTCV^PSOREJP1(RX,RFL,1) ; returns TRICARE, CHAMPVA or VETERAN
"RTN","PSOREJU3",224,0)
I $L(ELDSP) S ELDSP=ELDSP_" - " ; Add the " - " for CVA/TRI only
"RTN","PSOREJU3",225,0)
;
"RTN","PSOREJU3",226,0)
I $G(PSONBILL) S TAB=$S($L(ELDSP):24,1:29) W !!?TAB,"*** "_ELDSP_"NON-BILLABLE ***" Q
"RTN","PSOREJU3",227,0)
I $G(PSONPROG) S TAB=$S($L(ELDSP):18,1:23) W !!?TAB,"*** "_ELDSP_"'IN PROGRESS' ECME status ***" Q
"RTN","PSOREJU3",228,0)
S TAB=$S($L(ELDSP):11,1:16) W !!?TAB,"*** "_ELDSP_"REJECT RECEIVED FROM THIRD PARTY PAYER ***"
"RTN","PSOREJU3",229,0)
Q
"RTN","PSOREJU3",230,0)
;
"RTN","PSOREJU3",231,0)
SUBMIT(RXIEN,RFCNT,PSOTRIC) ;called from PSOCAN2 (routine size exceeded)
"RTN","PSOREJU3",232,0)
N SUBMITE S SUBMITE=$$SUBMIT^PSOBPSUT(RXIEN)
"RTN","PSOREJU3",233,0)
I SUBMITE D
"RTN","PSOREJU3",234,0)
. N ACTION
"RTN","PSOREJU3",235,0)
. D ECMESND^PSOBPSU1(RXIEN,,,$S($O(^PSRX(RXIEN,1,0)):"RF",1:"OF"))
"RTN","PSOREJU3",236,0)
. ; Quit if there is an unresolved TRICARE or CHAMPVA non-billable reject code, PSO*7*358
"RTN","PSOREJU3",237,0)
. I $$PSOET^PSOREJP3(RXIEN) S ACTION="Q" Q
"RTN","PSOREJU3",238,0)
. I $$FIND^PSOREJUT(RXIEN) S ACTION=$$HDLG^PSOREJU1(RXIEN,,"79,88","OF","IOQ","Q")
"RTN","PSOREJU3",239,0)
I 'SUBMITE&(PSOTRIC) D
"RTN","PSOREJU3",240,0)
. I $$STATUS^PSOBPSUT(RXIEN,RFCNT'["PAYABLE") D TRICCHK(RXIEN,RFCNT)
"RTN","PSOREJU3",241,0)
Q
"RTN","PSOREJU3",242,0)
;
"RTN","PSOREJU3",243,0)
TRISTA(RX,RFL,RESP,FROM,RVTX) ;called from suspense
"RTN","PSOREJU3",244,0)
N ETOUT,ESTAT,TRESP,TSTAT,PSOTRIC
"RTN","PSOREJU3",245,0)
S:'$D(RESP) RESP=""
"RTN","PSOREJU3",246,0)
S (ESTAT,PSOTRIC)="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
"RTN","PSOREJU3",247,0)
Q:'PSOTRIC 0
"RTN","PSOREJU3",248,0)
S TRESP=RESP,ESTAT=$P(TRESP,"^",4) S:ESTAT="" ESTAT=$$STATUS^PSOBPSUT(RX,RFL)
"RTN","PSOREJU3",249,0)
Q:ESTAT["E PAYABLE" 0
"RTN","PSOREJU3",250,0)
I $$TRIAUD(RX,RFL) D Q 0 ;if TRICARE or CHAMPVA Rx is in audit due to override or bypass, allow to print from suspense, cnf
"RTN","PSOREJU3",251,0)
. D LOG^BPSOSL($$IEN59^BPSOSRX(RX,RFL),$T(+0)_"-TRISTA, $$TRIAUD returned 1, $$TRISTA is Quitting with 0") ; ICR#s 4412,6764
"RTN","PSOREJU3",252,0)
I +RESP=2,$$BYPASS^PSOBPSU1($P(RESP,"^",3),$P(RESP,"^",2)) D Q 0 ;if 'Bypass' RX, allow to print from suspense, cnf
"RTN","PSOREJU3",253,0)
. D LOG^BPSOSL($$IEN59^BPSOSRX(RX,RFL),$T(+0)_"-TRISTA, $$BYPASS returned 1, $$TRISTA is Quitting with 0") ; ICR#s 4412,6764
"RTN","PSOREJU3",254,0)
Q:ESTAT["E REJECTED" 1 ;rejected TRICARE or CHAMPVA is not allowed to print from suspense
"RTN","PSOREJU3",255,0)
;if 'in progress' (4) or not billable (2,3) don't allow to print from suspense (IA 4415 Values)
"RTN","PSOREJU3",256,0)
I '$D(RESP)!($P(RESP,"^",1)="")!($G(RESP)="") D
"RTN","PSOREJU3",257,0)
. S TSTAT=$$STATUS^PSOBPSUT(RX,RFL) S TRESP=$S(TSTAT["IN PROGRESS":4,TSTAT["NOT BILLABLE":2,1:0)
"RTN","PSOREJU3",258,0)
. S $P(TRESP,"^",4)=TSTAT
"RTN","PSOREJU3",259,0)
;
"RTN","PSOREJU3",260,0)
I +TRESP=2!(+TRESP=3) D Q 1
"RTN","PSOREJU3",261,0)
. D WRKLST^PSOREJU4(RX,RFL,"",DUZ,DT,1,"",RESP) ;send TRICARE or CHAMPVA non billable to worklist (pseudo reject), cnf
"RTN","PSOREJU3",262,0)
. D LOG^BPSOSL($$IEN59^BPSOSRX(RX,RFL),$T(+0)_"-TRISTA, calling WRKLST~PSOREJU4, $$TRISTA is Quitting with 1") ; ICR#s 4412,6764
"RTN","PSOREJU3",263,0)
I +TRESP=4!(ESTAT["IN PROGRESS") D Q 1
"RTN","PSOREJU3",264,0)
. D LOG^BPSOSL($$IEN59^BPSOSRX(RX,RFL),$T(+0)_"-TRISTA, TRESP="_TRESP_", ESTAT="_ESTAT_", $$TRISTA is Quitting with 1") ; ICR#s 4412,6764
"RTN","PSOREJU3",265,0)
Q 0
"RTN","PSOREJU3",266,0)
;
"RTN","PSOREJU3",267,0)
TRIAUD(RXIEN,RXFILL) ;is RXIEN in the TRICARE/CHAMPVA audit and no open rejects ;cnf
"RTN","PSOREJU3",268,0)
; RXIEN will only be in TRICARE/CHAMPVA audit if a bypass or override has occurred and rejects are closed
"RTN","PSOREJU3",269,0)
; returns 0 if RXIEN is not in TRICARE/CHAMPVA audit at all or not in audit for right fill number
"RTN","PSOREJU3",270,0)
; rejects must be closed for 0 to be returned
"RTN","PSOREJU3",271,0)
; 1 if RXIEN is in TRICARE/CHAMPVA audit for the right fill number and rejects are closed
"RTN","PSOREJU3",272,0)
;
"RTN","PSOREJU3",273,0)
N X,AUDIEN,REJIEN
"RTN","PSOREJU3",274,0)
S X=0,AUDIEN=""
"RTN","PSOREJU3",275,0)
I '$D(^PS(52.87,"C",RXIEN)) Q X ;RXIEN is not in the TRICARE/CHAMPVA audit
"RTN","PSOREJU3",276,0)
;
"RTN","PSOREJU3",277,0)
I $G(RXFILL)="" S RXFILL=$$LSTRFL^PSOBPSU1(RXIEN) ;Get latest fill if not passed in
"RTN","PSOREJU3",278,0)
;
"RTN","PSOREJU3",279,0)
;check audit entries for right fill number
"RTN","PSOREJU3",280,0)
F S AUDIEN=$O(^PS(52.87,"C",RXIEN,AUDIEN)) Q:AUDIEN="" I RXFILL=$$GET1^DIQ(52.87,AUDIEN,2) S X=1 Q
"RTN","PSOREJU3",281,0)
I 'X Q X
"RTN","PSOREJU3",282,0)
;
"RTN","PSOREJU3",283,0)
;make sure rejects are closed
"RTN","PSOREJU3",284,0)
S REJIEN=0
"RTN","PSOREJU3",285,0)
F S REJIEN=$O(^PSRX(RXIEN,"REJ",REJIEN)) Q:'+REJIEN D I 'X Q ;I 'X, then the reject is not closed
"RTN","PSOREJU3",286,0)
. S X=$$CLOSED^PSOREJP1(RXIEN,REJIEN,0)
"RTN","PSOREJU3",287,0)
;
"RTN","PSOREJU3",288,0)
Q X
"RTN","PSOREJU3",289,0)
;
"RTN","PSOREJU3",290,0)
ECMECHK(RX,FILL) ;
"RTN","PSOREJU3",291,0)
; This function returns a '1' if any of the conditions below are met:
"RTN","PSOREJU3",292,0)
; - RX has an unresolved DUR or Refill Too Soon reject
"RTN","PSOREJU3",293,0)
; - RX has an unresolved Reject Resolution Required (RRR) reject (only for Veteran and original fill)
"RTN","PSOREJU3",294,0)
; - RX is TRICARE/CHAMPVA and has any unresolved reject
"RTN","PSOREJU3",295,0)
; - RX is TRICARE/CHAMPVA and IN PROGRESS
"RTN","PSOREJU3",296,0)
; This is used by functions such as PPLADD^PSOSUPOE to determine if
"RTN","PSOREJU3",297,0)
; a label should be printed (we do not want a label for the conditions)
"RTN","PSOREJU3",298,0)
;
"RTN","PSOREJU3",299,0)
; Incoming Parameters:
"RTN","PSOREJU3",300,0)
; RX - Internal IEN of the Prescription File (required)
"RTN","PSOREJU3",301,0)
; FILL - Fill Number (optional, defaults to last fill if not passed in)
"RTN","PSOREJU3",302,0)
; Returns:
"RTN","PSOREJU3",303,0)
; 0 - None of the conditions exists
"RTN","PSOREJU3",304,0)
; 1 - One of the conditions above is met
"RTN","PSOREJU3",305,0)
;
"RTN","PSOREJU3",306,0)
I '$G(RX) Q 0
"RTN","PSOREJU3",307,0)
I $G(FILL)="" S FILL=$$LSTRFL^PSOBPSU1(RX)
"RTN","PSOREJU3",308,0)
;
"RTN","PSOREJU3",309,0)
; DUR or Refill Too Soon or RRR rejects
"RTN","PSOREJU3",310,0)
I $$FIND^PSOREJUT(RX,FILL,"","79,88",,1) Q 1
"RTN","PSOREJU3",311,0)
;
"RTN","PSOREJU3",312,0)
; If not TRICARE/CHAMPVA, quit with 0 as the rest of the checks
"RTN","PSOREJU3",313,0)
; are all TRICARE/CHAMPVA dependent
"RTN","PSOREJU3",314,0)
I '$$TRIC^PSOREJP1(RX,FILL) Q 0
"RTN","PSOREJU3",315,0)
;
"RTN","PSOREJU3",316,0)
; No label for TRICARE/CHAMPVA with unresolved rejects
"RTN","PSOREJU3",317,0)
I $$FIND^PSOREJUT(RX,FILL,,,1) Q 1 ; 5th parameter to $$FIND also finds non-billable TRI/CVA rejects
"RTN","PSOREJU3",318,0)
;
"RTN","PSOREJU3",319,0)
;No label for TRICARE/CHAMPVA claims that are IN PROGRESS
"RTN","PSOREJU3",320,0)
I $P($$STATUS^PSOBPSUT(RX,FILL),U)="IN PROGRESS" Q 1
"RTN","PSOREJU3",321,0)
Q 0
"RTN","PSOREJU3",322,0)
;
"RTN","PSOREJU3",323,0)
DVINFO(RX,RFL,LM) ; Returns header displayable Division Information
"RTN","PSOREJU3",324,0)
;Input: (r) RX - Rx IEN (#52)
"RTN","PSOREJU3",325,0)
; (o) RFL - Refill # (Default: most recent)
"RTN","PSOREJU3",326,0)
; (o) LM - ListManager format? (1 - Yes / 0 - No) - Default: 0
"RTN","PSOREJU3",327,0)
N TXT,DVINFO,NCPNPI,DVIEN
"RTN","PSOREJU3",328,0)
S DVIEN=+$$RXSITE^PSOBPSUT(RX,RFL)
"RTN","PSOREJU3",329,0)
S DVINFO="Division : "_$$GET1^DIQ(59,DVIEN,.01)
"RTN","PSOREJU3",330,0)
;Display both NPI and NCPDP numbers - PSO*7.0*421
"RTN","PSOREJU3",331,0)
S NCPNPI=$$DIVNCPDP^BPSBUTL(DVIEN)
"RTN","PSOREJU3",332,0)
S $E(DVINFO,33)="NPI: "_$P(NCPNPI,U,2)
"RTN","PSOREJU3",333,0)
S $E(DVINFO,$S($G(LM):59,1:52))="NCPDP: "_$P(NCPNPI,U)
"RTN","PSOREJU3",334,0)
Q DVINFO
"RTN","PSOREJUT")
0^9^B114631275
"RTN","PSOREJUT",1,0)
PSOREJUT ;BIRM/MFR - BPS (ECME) - Clinical Rejects Utilities ;06/07/05
"RTN","PSOREJUT",2,0)
;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289,290,358,359,385,403,421,427,448,478,528**;DEC 1997;Build 8
"RTN","PSOREJUT",3,0)
;Reference to DUR1^BPSNCPD3 supported by IA 4560
"RTN","PSOREJUT",4,0)
;Reference to $$ADDCOMM^BPSBUTL supported by IA 4719
"RTN","PSOREJUT",5,0)
;
"RTN","PSOREJUT",6,0)
SAVE(RX,RFL,REJ,REOPEN) ; - Saves DUR Information in the file 52
"RTN","PSOREJUT",7,0)
; Input: (r) RX - Rx IEN (#52)
"RTN","PSOREJUT",8,0)
; (o) RFL - Refill # (Default: most recent)
"RTN","PSOREJUT",9,0)
; (o) REOPEN - value of 1 means claim being reopened; null or no value passed means reopen claim functionality not being used
"RTN","PSOREJUT",10,0)
; (r) REJ - Array containing information about the REJECT on the following subscripts:
"RTN","PSOREJUT",11,0)
; "BIN" - BIN Number
"RTN","PSOREJUT",12,0)
; "PCN" - PCN Number
"RTN","PSOREJUT",13,0)
; "CODE" - Reject Code (79 or 88)
"RTN","PSOREJUT",14,0)
; "DATE/TIME" - Date/Time Reject Detected
"RTN","PSOREJUT",15,0)
; "PAYER MESSAGE" - Message returned by Payer (up to 140 chars long)
"RTN","PSOREJUT",16,0)
; "REASON" - Reject Reason (up to 100 chars long)
"RTN","PSOREJUT",17,0)
; "DUR TEXT" - Payer's DUR description
"RTN","PSOREJUT",18,0)
; "DUR ADD MSG TEXT" - Payer's DUR additional message text description
"RTN","PSOREJUT",19,0)
; "INSURANCE NAME" - Patient's Insurance Company Name
"RTN","PSOREJUT",20,0)
; "INSURANCE POINTER" - Patient's Insurance Company IEN
"RTN","PSOREJUT",21,0)
; "GROUP NAME" - Patient's Insurance Group Name
"RTN","PSOREJUT",22,0)
; "GROUP NUMBER" - Patient's Insurance Group Number
"RTN","PSOREJUT",23,0)
; "CARDHOLDER ID" - Patient's Insurance Cardholder ID
"RTN","PSOREJUT",24,0)
; "COB" - Coordination of Benefits
"RTN","PSOREJUT",25,0)
; "PLAN CONTACT" - Patient's Insurance Plan Contact (1-800)
"RTN","PSOREJUT",26,0)
; "PREVIOUS FILL" - Plan's Previous Fill Date
"RTN","PSOREJUT",27,0)
; "OTHER REJECTS" - Other Rejects with same Response
"RTN","PSOREJUT",28,0)
; "PHARMACIST" - Pharmacist DUZ
"RTN","PSOREJUT",29,0)
; "RESPONSE IEN" - Pointer to the RESPONSE file in ECME
"RTN","PSOREJUT",30,0)
; "REASON SVC CODE" - Reason for Service Code (pointer to BPS NCPDP REASON FOR SERVICE CODE)
"RTN","PSOREJUT",31,0)
; "RE-OPENED" - Re-Open Flag
"RTN","PSOREJUT",32,0)
; "RRR FLAG" - Reject Resolution Required indicator (expecting 1/0 into SAVE)
"RTN","PSOREJUT",33,0)
; "RRR THRESHOLD AMT" - Reject Resolution Required Dollar Threshold
"RTN","PSOREJUT",34,0)
; "RRR GROSS AMT DUE" - Reject Resolution Required Gross Amount Due
"RTN","PSOREJUT",35,0)
;Output: REJ("REJECT IEN")
"RTN","PSOREJUT",36,0)
N %,DIC,DR,DA,X,DINUM,DD,DO,DLAYGO,ERR
"RTN","PSOREJUT",37,0)
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
"RTN","PSOREJUT",38,0)
I '$G(PSODIV) S PSODIV=$$RXSITE^PSOBPSUT(RX,RFL)
"RTN","PSOREJUT",39,0)
S REJ("BIN")=$E($G(REJ("BIN")),1,6)
"RTN","PSOREJUT",40,0)
S REJ("PCN")=$G(REJ("PCN"))
"RTN","PSOREJUT",41,0)
S REJ("CODE")=$G(REJ("CODE"))
"RTN","PSOREJUT",42,0)
;
"RTN","PSOREJUT",43,0)
; convert REJ("RRR FLAG") into internal format (1/0) if necessary. When coming into SAVE from the Re-open Reject
"RTN","PSOREJUT",44,0)
; action, this flag is in the external format (YES/NO). esg - 3/29/16 - PSO*7*448
"RTN","PSOREJUT",45,0)
I $G(REJ("RRR FLAG"))="YES" S REJ("RRR FLAG")=1
"RTN","PSOREJUT",46,0)
I $G(REJ("RRR FLAG"))="NO" S REJ("RRR FLAG")=0
"RTN","PSOREJUT",47,0)
;
"RTN","PSOREJUT",48,0)
;Ignore this additional Check if reject is Reject Resolution Required reject - PSO*7*421
"RTN","PSOREJUT",49,0)
I '$G(REJ("RRR FLAG")),REJ("CODE")'=79&(REJ("CODE")'=88)&('$G(PSOTRIC))&('$G(REOPEN)) S ERR=$$EVAL^PSOREJU4(PSODIV,REJ("CODE"),$G(OPECC)) Q:'+ERR
"RTN","PSOREJUT",50,0)
S REJ("PAYER MESSAGE")=$E($G(REJ("PAYER MESSAGE")),1,140),REJ("REASON")=$E($G(REJ("REASON")),1,100)
"RTN","PSOREJUT",51,0)
S REJ("DUR TEXT")=$E($G(REJ("DUR TEXT")),1,100),REJ("DUR ADD MSG TEXT")=$E($G(REJ("DUR ADD MSG TEXT")),1,100),REJ("GROUP NAME")=$E($G(REJ("GROUP NAME")),1,30)
"RTN","PSOREJUT",52,0)
S REJ("INSURANCE NAME")=$E($G(REJ("INSURANCE NAME")),1,30),REJ("PLAN CONTACT")=$E($G(REJ("PLAN CONTACT")),1,30)
"RTN","PSOREJUT",53,0)
S REJ("GROUP NUMBER")=$E($G(REJ("GROUP NUMBER")),1,30),REJ("OTHER REJECTS")=$E($G(REJ("OTHER REJECTS")),1,15)
"RTN","PSOREJUT",54,0)
S REJ("CARDHOLDER ID")=$E($G(REJ("CARDHOLDER ID")),1,20),REJ("COB")=$G(REJ("COB"))
"RTN","PSOREJUT",55,0)
I $G(REJ("DATE/TIME"))="" D NOW^%DTC S REJ("DATE/TIME")=%
"RTN","PSOREJUT",56,0)
S DIC="^PSRX("_RX_",""REJ"",",DA(1)=RX,DIC(0)=""
"RTN","PSOREJUT",57,0)
S X=$G(REJ("CODE")),DINUM=$O(^PSRX(RX,"REJ",9999),-1)+1
"RTN","PSOREJUT",58,0)
S DIC("DR")="1///"_$G(REJ("DATE/TIME"))_";2///"_REJ("PAYER MESSAGE")_";3///"_REJ("REASON")_";4////"_$G(REJ("PHARMACIST"))_";5///"_RFL
"RTN","PSOREJUT",59,0)
S DIC("DR")=DIC("DR")_";6///"_REJ("GROUP NAME")_";7///"_REJ("PLAN CONTACT")_";8///"_$G(REJ("PREVIOUS FILL"))
"RTN","PSOREJUT",60,0)
S DIC("DR")=DIC("DR")_";9///0;14///"_$G(REJ("REASON SVC CODE"))_";16///"_$G(REJ("RESPONSE IEN"))
"RTN","PSOREJUT",61,0)
S DIC("DR")=DIC("DR")_";17///"_$G(REJ("OTHER REJECTS"))_";18///"_REJ("DUR TEXT")_";20///"_REJ("INSURANCE NAME")
"RTN","PSOREJUT",62,0)
S DIC("DR")=DIC("DR")_";21///"_REJ("GROUP NUMBER")_";22///"_REJ("CARDHOLDER ID")_";23///"_$G(REJ("RE-OPENED"))
"RTN","PSOREJUT",63,0)
S DIC("DR")=DIC("DR")_";27///"_REJ("COB")
"RTN","PSOREJUT",64,0)
S DIC("DR")=DIC("DR")_";28///"_REJ("DUR ADD MSG TEXT")
"RTN","PSOREJUT",65,0)
S DIC("DR")=DIC("DR")_";29///"_REJ("BIN")
"RTN","PSOREJUT",66,0)
S DIC("DR")=DIC("DR")_";34///"_REJ("PCN")
"RTN","PSOREJUT",67,0)
;Update Reject Resolution Required fields - PSO*7*421
"RTN","PSOREJUT",68,0)
I $G(REJ("RRR FLAG")) D
"RTN","PSOREJUT",69,0)
.S DIC("DR")=DIC("DR")_";30///"_REJ("RRR FLAG")
"RTN","PSOREJUT",70,0)
.S DIC("DR")=DIC("DR")_";31///"_REJ("RRR THRESHOLD AMT")
"RTN","PSOREJUT",71,0)
.S DIC("DR")=DIC("DR")_";32///"_REJ("RRR GROSS AMT DUE")
"RTN","PSOREJUT",72,0)
S DIC("DR")=DIC("DR")_";33///"_REJ("INSURANCE POINTER")
"RTN","PSOREJUT",73,0)
F L +^PSRX(RX):5 Q:$T H 15
"RTN","PSOREJUT",74,0)
K DD,DO D FILE^DICN K DD,DO S REJ("REJECT IEN")=+Y
"RTN","PSOREJUT",75,0)
S REJ("OVERRIDE MSG")=$G(DATA("OVERRIDE MSG"))
"RTN","PSOREJUT",76,0)
;Comments use POSTMASTER as user for auto transfers - PSO*7*421
"RTN","PSOREJUT",77,0)
I REJ("OVERRIDE MSG")'="" D
"RTN","PSOREJUT",78,0)
.N ORIGIN S ORIGIN=$G(DUZ)
"RTN","PSOREJUT",79,0)
.S:REJ("OVERRIDE MSG")["Automatically transferred" ORIGIN=.5
"RTN","PSOREJUT",80,0)
.D SAVECOM^PSOREJP3(RX,REJ("REJECT IEN"),REJ("OVERRIDE MSG"),$G(REJ("DATE/TIME")),ORIGIN)
"RTN","PSOREJUT",81,0)
.;Insert comment for Transfer and RRR Rejects - PSO*7*421
"RTN","PSOREJUT",82,0)
.I REJ("OVERRIDE MSG")["Automatically transferred" D
"RTN","PSOREJUT",83,0)
..N X,TXT
"RTN","PSOREJUT",84,0)
..S TXT="Auto Send to Pharmacy Worklist due to Transfer Reject Code"
"RTN","PSOREJUT",85,0)
..I $G(REJ("RRR FLAG")) S TXT="Auto Send to Pharmacy Worklist due to Reject Resolution Required Code"
"RTN","PSOREJUT",86,0)
..I $G(PSOTRIC) S TXT="Auto Send to Pharmacy Worklist & OPECC - CVA/TRI"
"RTN","PSOREJUT",87,0)
..S X=$$ADDCOMM^BPSBUTL(RX,RFL,TXT,1) ; IA 4719
"RTN","PSOREJUT",88,0)
L -^PSRX(RX)
"RTN","PSOREJUT",89,0)
Q
"RTN","PSOREJUT",90,0)
;
"RTN","PSOREJUT",91,0)
CLSALL(RX,RFL,USR,REA,COM,COD1,COD2,COD3,CLA,PA) ; Close/Resolve All Rejects
"RTN","PSOREJUT",92,0)
;Input: (r) RX - Rx IEN (#52)
"RTN","PSOREJUT",93,0)
; (o) RFL - Refill # (Default: most recent)
"RTN","PSOREJUT",94,0)
; (o) USR - User DUZ responsible for closing all rejects
"RTN","PSOREJUT",95,0)
; (r) REA - Close REASON code
"RTN","PSOREJUT",96,0)
; (o) COM - Close COMMENTS
"RTN","PSOREJUT",97,0)
; (o) COD1 - First set of DUR overrides (Reason Code^Professional Code^Result Code)
"RTN","PSOREJUT",98,0)
; (o) COD2 - Second set of DUR overrides (Reason Code^Professional Code^Result Code)
"RTN","PSOREJUT",99,0)
; (o) COD3 - Third set of DUR overrides (Reason Code^Professional Code^Result Code)
"RTN","PSOREJUT",100,0)
; (o) CLA - NCPDP Clarification Code for overriding RTS and DUR REJECTS
"RTN","PSOREJUT",101,0)
; (o) PA - NCPDP Prior Authorization Type and Number (separated by "^")
"RTN","PSOREJUT",102,0)
N REJ,REJDATA,DIE,DR,DA
"RTN","PSOREJUT",103,0)
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
"RTN","PSOREJUT",104,0)
; - if eT,eC Non-Billable and the claim was Re-submitted don't close OPEN/UNRESOLVED rejects
"RTN","PSOREJUT",105,0)
I $G(REA)=1 I $$PSOETEC^PSOREJP5(RX,RFL) Q
"RTN","PSOREJUT",106,0)
; - Closing OPEN/UNRESOLVED rejects
"RTN","PSOREJUT",107,0)
I $$FIND(RX,RFL,.REJDATA,,1) D
"RTN","PSOREJUT",108,0)
. S REJ="" F S REJ=$O(REJDATA(REJ)) Q:'REJ D
"RTN","PSOREJUT",109,0)
. . D CLOSE(RX,RFL,REJ,USR,REA,$G(COM),$G(COD1),$G(COD2),$G(COD3),$G(CLA),$G(PA))
"RTN","PSOREJUT",110,0)
Q
"RTN","PSOREJUT",111,0)
;
"RTN","PSOREJUT",112,0)
CLOSE(RX,RFL,REJ,USR,REA,COM,COD1,COD2,COD3,CLA,PA,IGNR) ; - Mark a DUR/REFILL TOO SOON reject RESOLVED
"RTN","PSOREJUT",113,0)
; Input: (r) RX - Rx IEN (#52)
"RTN","PSOREJUT",114,0)
; (o) RFL - Refill # (Default: most recent)
"RTN","PSOREJUT",115,0)
; (r) REJ - REJECT ID (IEN)
"RTN","PSOREJUT",116,0)
; (o) USR - User (file #200 IEN) responsible for closing the REJECT
"RTN","PSOREJUT",117,0)
; (r) REA - Reason for closing the REJECT (52.25,12):
"RTN","PSOREJUT",118,0)
; 1:CLAIM RE-SUBMITTED
"RTN","PSOREJUT",119,0)
; 2:RX ON HOLD
"RTN","PSOREJUT",120,0)
; 3:RX SUSPENDED
"RTN","PSOREJUT",121,0)
; 4:RX RETURNED TO STOCK
"RTN","PSOREJUT",122,0)
; 5:RX DELETED
"RTN","PSOREJUT",123,0)
; 6:IGNORED - NO RESUBMISSION
"RTN","PSOREJUT",124,0)
; 7:RX DISCONTINUED
"RTN","PSOREJUT",125,0)
; 8:RX EDITED
"RTN","PSOREJUT",126,0)
; 99:OTHER
"RTN","PSOREJUT",127,0)
; (o) COM - Close comments manually entered by the user
"RTN","PSOREJUT",128,0)
; (o) COD1 - First set of DUR overrides (Reason Code^Professional Code^Result Code)
"RTN","PSOREJUT",129,0)
; (o) COD2 - Second set of DUR overrides (Reason Code^Professional Code^Result Code)
"RTN","PSOREJUT",130,0)
; (o) COD3 - Third set of DUR overrides (Reason Code^Professional Code^Result Code)
"RTN","PSOREJUT",131,0)
; (o) CLA - NCPDP Clarification Code for overriding RTS and DUR REJECTS
"RTN","PSOREJUT",132,0)
; (o) PA - NCPDP Prior Authorization Type and Number (separated by "^")
"RTN","PSOREJUT",133,0)
; (o) IGNR - Ignore Flag; 1=IGNORE, 0=NOT IGNORE
"RTN","PSOREJUT",134,0)
;
"RTN","PSOREJUT",135,0)
I '$G(RX)!'$G(REJ) Q
"RTN","PSOREJUT",136,0)
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
"RTN","PSOREJUT",137,0)
I '$D(^PSRX(RX,"REJ",REJ)) Q
"RTN","PSOREJUT",138,0)
I $$GET1^DIQ(52.25,REJ_","_RX,5)'=+$G(RFL) Q
"RTN","PSOREJUT",139,0)
S:'$G(REA) REA=99 S COM=$TR($G(COM),";^",",,")
"RTN","PSOREJUT",140,0)
N DQ,DA,DIE,DR,X,Y,REJCOM,I,SMACOM,SMA
"RTN","PSOREJUT",141,0)
D NOW^%DTC
"RTN","PSOREJUT",142,0)
S REJCOM="AUTOMATICALLY CLOSED" I REA'=1 S REJCOM=COM
"RTN","PSOREJUT",143,0)
S DA(1)=RX,DA=REJ,DIE="^PSRX("_RX_",""REJ"","
"RTN","PSOREJUT",144,0)
S DR="9///1;10///"_%_";11////"_$G(USR)_";12///"_REA_";13///"_REJCOM_";14///"_$P($G(COD1),"^")_";15///"_$P($G(COD1),"^",2)
"RTN","PSOREJUT",145,0)
S DR=DR_";19///"_$P($G(COD1),"^",3)_";24///"_$G(CLA)_";25///"_$P($G(PA),"^")_";26///"_$P($G(PA),"^",2)
"RTN","PSOREJUT",146,0)
D ^DIE
"RTN","PSOREJUT",147,0)
; Quit if this is a "eT" (non-billable TRICARE) or "eC" (non-billable CHAMPVA)
"RTN","PSOREJUT",148,0)
Q:$$PSOET^PSOREJP3(RX,RFL)
"RTN","PSOREJUT",149,0)
;
"RTN","PSOREJUT",150,0)
; Add comment to the ECME User Screen
"RTN","PSOREJUT",151,0)
; First check if this is has more than one override value from the SMA action of the reject worklist
"RTN","PSOREJUT",152,0)
; If it is, we will need to enter multiple comments
"RTN","PSOREJUT",153,0)
S SMA=0
"RTN","PSOREJUT",154,0)
I $G(COD1)]"",$G(CLA)]"" S SMA=1
"RTN","PSOREJUT",155,0)
I $G(COD1)]"",$G(PA)]"" S SMA=1
"RTN","PSOREJUT",156,0)
I $G(CLA)]"",$G(PA)]"" S SMA=1
"RTN","PSOREJUT",157,0)
I SMA D Q
"RTN","PSOREJUT",158,0)
. I $G(COD1)]"" D
"RTN","PSOREJUT",159,0)
.. S SMACOM=$TR("DUR Override Codes "_$G(COD1)_"~"_$G(COD2)_"~"_$G(COD3)_" submitted.","^","/")
"RTN","PSOREJUT",160,0)
.. S X=$$ADDCOMM^BPSBUTL(RX,RFL,SMACOM)
"RTN","PSOREJUT",161,0)
. I $G(CLA)]"" D
"RTN","PSOREJUT",162,0)
.. S SMACOM="Clarification Code(s) "_CLA_" submitted."
"RTN","PSOREJUT",163,0)
.. S X=$$ADDCOMM^BPSBUTL(RX,RFL,SMACOM)
"RTN","PSOREJUT",164,0)
. I $G(PA)]"" D
"RTN","PSOREJUT",165,0)
.. S SMACOM="Prior Authorization Code ("_$P(PA,"^")_"/"_$P(PA,"^",2)_") submitted."
"RTN","PSOREJUT",166,0)
.. S X=$$ADDCOMM^BPSBUTL(RX,RFL,SMACOM)
"RTN","PSOREJUT",167,0)
. S SMACOM="Multiple actions taken to resolve. See comments for details."
"RTN","PSOREJUT",168,0)
. S X=$$ADDCOMM^BPSBUTL(RX,RFL,SMACOM)
"RTN","PSOREJUT",169,0)
;
"RTN","PSOREJUT",170,0)
; If not SMA, fall through to here and enter one comment
"RTN","PSOREJUT",171,0)
; If IGNR flag is set, add that to the comment string before sending
"RTN","PSOREJUT",172,0)
S X=$$ADDCOMM^BPSBUTL(RX,RFL,$S($G(IGNR):"IGNORED - ",1:"")_COM)
"RTN","PSOREJUT",173,0)
Q
"RTN","PSOREJUT",174,0)
;
"RTN","PSOREJUT",175,0)
FIND(RX,RFL,REJDATA,CODE,BESC,RRRFLG) ; - Returns whether a Rx/fill contains UNRESOLVED rejects
"RTN","PSOREJUT",176,0)
; Input: (r) RX - Rx IEN (#52)
"RTN","PSOREJUT",177,0)
; (o) RFL - Refill # (If not passed, look original and all refills)
"RTN","PSOREJUT",178,0)
; (o) CODE - Can be null, a specific Reject Code(s) to be checked or multiple codes separated by comma's
"RTN","PSOREJUT",179,0)
; (o) BESC - Bypass ECME Status Check (default behavior is to do the check); pass 1 to skip the check below
"RTN","PSOREJUT",180,0)
; We need to skip this check when looking for non-ECME billable rejects (eT or eC for example)
"RTN","PSOREJUT",181,0)
; (o) RRRFLG - Pass a 1 in this parameter to also look for any unresolved Reject Resolution Required (RRR)
"RTN","PSOREJUT",182,0)
; rejects when CODE is also passed. If CODE is not passed in, then pass a 1 here to ONLY look for
"RTN","PSOREJUT",183,0)
; unresolved RRR rejects.
"RTN","PSOREJUT",184,0)
; The default here is 0 if not passed.
"RTN","PSOREJUT",185,0)
;
"RTN","PSOREJUT",186,0)
; Output: 1 - Rx contains unresolved Rejects
"RTN","PSOREJUT",187,0)
; 0 - Rx does not contain unresolved Rejects
"RTN","PSOREJUT",188,0)
; .REJDATA - Array containing the Reject(s) data (see GET^PSOREJU2 for fields documentation)
"RTN","PSOREJUT",189,0)
;
"RTN","PSOREJUT",190,0)
N RCODE,I,REJS
"RTN","PSOREJUT",191,0)
S REJS=0,RCODE=""
"RTN","PSOREJUT",192,0)
K REJDATA
"RTN","PSOREJUT",193,0)
I '$G(BESC),$G(RFL),$$STATUS^PSOBPSUT(RX,RFL)="" Q 0
"RTN","PSOREJUT",194,0)
I $G(CODE)]"",CODE["," S REJS=$$MULTI^PSOREJU4(RX,$G(RFL),.REJDATA,$G(CODE),REJS,+$G(RRRFLG)) G FEND
"RTN","PSOREJUT",195,0)
S REJS=$$SINGLE^PSOREJU4(RX,$G(RFL),.REJDATA,$G(CODE),REJS,+$G(RRRFLG))
"RTN","PSOREJUT",196,0)
FEND ;
"RTN","PSOREJUT",197,0)
Q $S(REJS:1,1:0)
"RTN","PSOREJUT",198,0)
;
"RTN","PSOREJUT",199,0)
SYNC(RX,RFL,USR,RXCOB) ;
"RTN","PSOREJUT",200,0)
; Input: (r) RX - Rx IEN (#52)
"RTN","PSOREJUT",201,0)
; (o) RFL - Refill # (Default: most recent)
"RTN","PSOREJUT",202,0)
; (o) USR - User using the system when this routine is called
"RTN","PSOREJUT",203,0)
; (o) RXCOB - Coordination of Benefits code
"RTN","PSOREJUT",204,0)
I '$G(RXCOB) S RXCOB=1
"RTN","PSOREJUT",205,0)
N REJ,REJS,REJLST,I,IDX,CODE,DATA,TXT,PSOTRIC,ERR,PSODIV,OPECC,OVREJ,ESH
"RTN","PSOREJUT",206,0)
N REJRRR,RRRVAL ; PSO*7*421
"RTN","PSOREJUT",207,0)
L +^PSRX("REJ",RX):0 Q:'$T
"RTN","PSOREJUT",208,0)
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
"RTN","PSOREJUT",209,0)
S PSODIV=$$RXSITE^PSOBPSUT(RX,RFL)
"RTN","PSOREJUT",210,0)
D DUR1^BPSNCPD3(RX,RFL,.REJ,"",RXCOB)
"RTN","PSOREJUT",211,0)
S PSOTRIC="" S:$G(REJ(1,"ELIGBLT"))="T" PSOTRIC=1 S:$G(REJ(1,"ELIGBLT"))="C" PSOTRIC=2 S:PSOTRIC="" PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,.PSOTRIC)
"RTN","PSOREJUT",212,0)
K REJS S (OPECC,IDX,ERR)=""
"RTN","PSOREJUT",213,0)
F S IDX=$O(REJ(IDX)) Q:IDX="" S TXT=$G(REJ(IDX,"REJ CODE LST")) D
"RTN","PSOREJUT",214,0)
. F I=1:1:$L(TXT,",") S CODE=$P(TXT,",",I),OVREJ="" D
"RTN","PSOREJUT",215,0)
. . I CODE="" Q
"RTN","PSOREJUT",216,0)
. . I ",M6,M8,99,NN,"[(","_CODE_",") S ESH="",ESH=$$DUR^PSOBPSU2(RX,RFL) Q:'ESH&('PSOTRIC)
"RTN","PSOREJUT",217,0)
. . ;Additional check for Reject Resolution Required included - PSO*7*421
"RTN","PSOREJUT",218,0)
. . I CODE'="79"&(CODE'="88")&('$G(PSOTRIC)) S ERR=$$EVAL^PSOREJU4(PSODIV,CODE,OPECC,RX,RFL,RXCOB,.RRRVAL) Q:'+ERR
"RTN","PSOREJUT",219,0)
. . I +$G(ERR) S OVREJ=1 S:+$G(RRRVAL) REJRRR(IDX)=RRRVAL
"RTN","PSOREJUT",220,0)
. . I $$DUP^PSOREJU1(RX,+$$CLEAN^PSOREJU1($G(REJ(IDX,"RESPONSE IEN")))) Q
"RTN","PSOREJUT",221,0)
. . S REJS(IDX,CODE)=OVREJ
"RTN","PSOREJUT",222,0)
I '$D(REJS) L -^PSRX("REJ",RX) Q
"RTN","PSOREJUT",223,0)
SYNC2 ;
"RTN","PSOREJUT",224,0)
S (IDX,CODE)="" F S IDX=$O(REJS(IDX)) Q:IDX="" D
"RTN","PSOREJUT",225,0)
. F S CODE=$O(REJS(IDX,CODE)) Q:CODE="" K DATA D
"RTN","PSOREJUT",226,0)
. . ;Additional check for Reject Resolution Required - PSO*7*421
"RTN","PSOREJUT",227,0)
. . I 'OPECC&(CODE'[79)&(CODE'[88) D
"RTN","PSOREJUT",228,0)
. . .I '+$G(REJRRR(IDX)) S DATA("OVERRIDE MSG")="Automatically transferred due to override for reject code." Q
"RTN","PSOREJUT",229,0)
. . .;Reject Resolution Required fields
"RTN","PSOREJUT",230,0)
. . .S DATA("RRR FLAG")=1
"RTN","PSOREJUT",231,0)
. . .S DATA("RRR GROSS AMT DUE")=$P(REJRRR(IDX),U,2)
"RTN","PSOREJUT",232,0)
. . .S DATA("RRR THRESHOLD AMT")=$P(REJRRR(IDX),U,3)
"RTN","PSOREJUT",233,0)
. . .S DATA("OVERRIDE MSG")="Automatically transferred due to Reject Resolution Required reject code"
"RTN","PSOREJUT",234,0)
. . I OPECC&(CODE'[79)&(CODE'[88) S DATA("OVERRIDE MSG")="Transferred by "_$S(CODE["eT":"",CODE["eC":"",1:"OPECC.") ;cnf,PSO*7.0*358
"RTN","PSOREJUT",235,0)
. . I $D(COMMTXT) S:COMMTXT'="" DATA("OVERRIDE MSG")=DATA("OVERRIDE MSG")_" "_$$CLEAN^PSOREJU1($P(COMMTXT,":",2))
"RTN","PSOREJUT",236,0)
. . S DATA("DUR TEXT")=$$CLEAN^PSOREJU1($G(REJ(IDX,"DUR FREE TEXT DESC")))
"RTN","PSOREJUT",237,0)
. . S DATA("DUR ADD MSG TEXT")=$$CLEAN^PSOREJU1($G(REJ(IDX,"DUR ADD MSG TEXT")))
"RTN","PSOREJUT",238,0)
. . ; In NCPDP D0, the Payer Additional Message is a repeating field and we want to display as much of the
"RTN","PSOREJUT",239,0)
. . ; data on the reject information screen as possible so we put the messages together up to the field
"RTN","PSOREJUT",240,0)
. . ; length of 140
"RTN","PSOREJUT",241,0)
. . N CNT,MSG
"RTN","PSOREJUT",242,0)
. . S CNT="",DATA("PAYER MESSAGE")=""
"RTN","PSOREJUT",243,0)
. . F S CNT=$O(REJ(IDX,"PAYER MESSAGE",CNT)) Q:CNT=""!($L(DATA("PAYER MESSAGE"))>140) D
"RTN","PSOREJUT",244,0)
. . . S MSG=$$CLEAN^PSOREJU1(REJ(IDX,"PAYER MESSAGE",CNT))
"RTN","PSOREJUT",245,0)
. . . I MSG]"" S DATA("PAYER MESSAGE")=DATA("PAYER MESSAGE")_MSG_" "
"RTN","PSOREJUT",246,0)
. . ; Call CLEAN again to strip the extra trailing spaces we might have added
"RTN","PSOREJUT",247,0)
. . S DATA("PAYER MESSAGE")=$$CLEAN^PSOREJU1(DATA("PAYER MESSAGE"))
"RTN","PSOREJUT",248,0)
. . S DATA("CODE")=CODE,DATA("REASON")=$$CLEAN^PSOREJU1($G(REJ(IDX,"REASON")))
"RTN","PSOREJUT",249,0)
. . S DATA("PHARMACIST")=$G(USR),DATA("INSURANCE NAME")=$$CLEAN^PSOREJU1($G(REJ(IDX,"INSURANCE NAME")))
"RTN","PSOREJUT",250,0)
. . S DATA("INSURANCE POINTER")=$$CLEAN^PSOREJU1($G(REJ(IDX,"INSURANCE POINTER")))
"RTN","PSOREJUT",251,0)
. . S DATA("GROUP NAME")=$$CLEAN^PSOREJU1($G(REJ(IDX,"GROUP NAME"))),DATA("GROUP NUMBER")=$$CLEAN^PSOREJU1($G(REJ(IDX,"GROUP NUMBER")))
"RTN","PSOREJUT",252,0)
. . S DATA("CARDHOLDER ID")=$$CLEAN^PSOREJU1($G(REJ(IDX,"CARDHOLDER ID"))),DATA("PLAN CONTACT")=$$CLEAN^PSOREJU1($G(REJ(IDX,"PLAN CONTACT")))
"RTN","PSOREJUT",253,0)
. . S DATA("PREVIOUS FILL")=$$CLEAN^PSOREJU1($$DAT^PSOREJU1($G(REJ(IDX,"PREVIOUS FILL DATE"))))
"RTN","PSOREJUT",254,0)
. . S DATA("OTHER REJECTS")=$$CLEAN^PSOREJU1($$OTH^PSOREJU1(CODE,$G(REJ(IDX,"REJ CODE LST"))))
"RTN","PSOREJUT",255,0)
. . S DATA("RESPONSE IEN")=+$$CLEAN^PSOREJU1($G(REJ(IDX,"RESPONSE IEN")))
"RTN","PSOREJUT",256,0)
. . S DATA("REASON SVC CODE")=$$REASON^PSOREJU2($G(REJ(IDX,"REASON"))),DATA("COB")=IDX
"RTN","PSOREJUT",257,0)
. . S DATA("MESSAGE")=$$CLEAN^PSOREJU1($G(REJ(IDX,"MESSAGE")))
"RTN","PSOREJUT",258,0)
. . S DATA("DUR RESPONSE DATA")=$$CLEAN^PSOREJU1($G(REJ(IDX,"DUR RESPONSE DATA")))
"RTN","PSOREJUT",259,0)
. . S DATA("BIN")=$$CLEAN^PSOREJU1($G(REJ(IDX,"BIN")))
"RTN","PSOREJUT",260,0)
. . S DATA("PCN")=$$CLEAN^PSOREJU1($G(REJ(IDX,"PCN")))
"RTN","PSOREJUT",261,0)
. . D SAVE(RX,RFL,.DATA)
"RTN","PSOREJUT",262,0)
L -^PSRX("REJ",RX)
"RTN","PSOREJUT",263,0)
Q
"RTN","PSORXPA1")
0^11^B38381777
"RTN","PSORXPA1",1,0)
PSORXPA1 ;BIR/SAB - listman partial prescriptions ;07/14/93
"RTN","PSORXPA1",2,0)
;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,287,385,442,528**;DEC 1997;Build 8
"RTN","PSORXPA1",3,0)
;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
"RTN","PSORXPA1",4,0)
;External reference to ^PSDRUG supported by DBIA 221
"RTN","PSORXPA1",5,0)
;External reference to ^DD(52 supported by DBIA 999
"RTN","PSORXPA1",6,0)
I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
"RTN","PSORXPA1",7,0)
;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q
"RTN","PSORXPA1",8,0)
I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q
"RTN","PSORXPA1",9,0)
S PSORPDFN=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",2)
"RTN","PSORXPA1",10,0)
S PSOPLCK=$$L^PSSLOCK(PSORPDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK,PSORPDFN D Q
"RTN","PSORXPA1",11,0)
.S VALMBCK=""
"RTN","PSORXPA1",12,0)
K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(PSORPDFN) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG,PSORPDFN Q
"RTN","PSORXPA1",13,0)
I '$G(RXPR($P(PSOLST(ORN),"^",2))) S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 I $G(QFLG) S VALMBCK="",VALMSG="A New Label has been requested already!" K QFLG,RX D ULK Q
"RTN","PSORXPA1",14,0)
D FULL^VALM1 I '$D(PSOPAR) D ^PSOLSET D:'$D(PSOPAR) ULK G:'$D(PSOPAR) KL
"RTN","PSORXPA1",15,0)
S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)) S:'$G(BBFLG) BBRX(1)=""
"RTN","PSORXPA1",16,0)
; BNT PSO*7*385
"RTN","PSORXPA1",17,0)
N PSOELIG,PSORF,PSOTRIC,PSOTCQ
"RTN","PSORXPA1",18,0)
; Get Patient Eligibility from PSORX("PATIENT STATUS") or PTST.
"RTN","PSORXPA1",19,0)
S PSOELIG=0
"RTN","PSORXPA1",20,0)
S PSOELIG=$S($E(PSORX("PATIENT STATUS"),1)="T":1,$G(PTST)="TRICARE":1,$E(PSORX("PATIENT STATUS"),1)="C":2,$G(PTST)="CHAMPVA":2,1:0)
"RTN","PSORXPA1",21,0)
S PSORF=$$LSTRFL^PSOBPSU1(DA),PSOTRIC=$$TRIC^PSOREJP1(DA,PSORF),PSOTCQ=0
"RTN","PSORXPA1",22,0)
; PSOELIG will contain the Patient's eligibility for Rx's where the BILLING ELIGIBILITY INDICATOR isn't populated.
"RTN","PSORXPA1",23,0)
I PSOTRIC!PSOELIG D Q:PSOTCQ
"RTN","PSORXPA1",24,0)
. ; Check for PSO TRICARE/CHAMPVA security key
"RTN","PSORXPA1",25,0)
. I '$D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) D Q
"RTN","PSORXPA1",26,0)
. . S PSOTCQ=1,VALMBCK="R",VALMSG="Action Requires <PSO TRICARE/CHAMPVA> security key"
"RTN","PSORXPA1",27,0)
. ; Is this RX non-billable?
"RTN","PSORXPA1",28,0)
. I $$ECME^PSOBPSUT(DA)="" D Q:PSOTCQ
"RTN","PSORXPA1",29,0)
. . N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PSORXPA1",30,0)
. . S DIR(0)="Y"
"RTN","PSORXPA1",31,0)
. . S DIR("A",1)="This partial fill is for a "_$$ELIGDISP^PSOREJP1(DA,PSORF)_" non-billable Rx and will not be reimbursed."
"RTN","PSORXPA1",32,0)
. . S DIR("A")="Do you wish to continue"
"RTN","PSORXPA1",33,0)
. . D ^DIR I Y'=1 S PSOTCQ=1,VALMBCK="R"
"RTN","PSORXPA1",34,0)
. ; Is this RX rejected?
"RTN","PSORXPA1",35,0)
. I $$STATUS^PSOBPSUT(DA,PSORF)="E REJECTED" D Q:PSOTCQ
"RTN","PSORXPA1",36,0)
. . N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PSORXPA1",37,0)
. . S DIR(0)="Y"
"RTN","PSORXPA1",38,0)
. . S DIR("A",1)="This partial fill is for a "_$$ELIGDISP^PSOREJP1(DA,PSORF)_" rejected Rx and will not be reimbursed."
"RTN","PSORXPA1",39,0)
. . S DIR("A")="Do you wish to continue"
"RTN","PSORXPA1",40,0)
. . D ^DIR I Y'=1 S PSOTCQ=1,VALMBCK="R"
"RTN","PSORXPA1",41,0)
I +$P($G(^PSRX(DA,2)),"^",6)<DT D
"RTN","PSORXPA1",42,0)
.S:$P($G(^PSRX(DA,"STA")),"^")<12 $P(^PSRX(DA,"STA"),"^")=11
"RTN","PSORXPA1",43,0)
.S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
"RTN","PSORXPA1",44,0)
.S STAT="SC",PHARMST="ZE" D EN^PSOHLSN1(DA,STAT,PHARMST,COMM) K STAT,PHARMST,COMM,RX0,J,RX2,R3
"RTN","PSORXPA1",45,0)
;I +$P($G(^PSRX(DA,2)),"^",6)<PSODTCUT D K DA S VALMBCK="R" Q
"RTN","PSORXPA1",46,0)
;.S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
"RTN","PSORXPA1",47,0)
I +^PSRX(DA,"STA"),+^("STA")'=5,+^("STA")'=11 D K DA S VALMBCK="R" D ULK Q
"RTN","PSORXPA1",48,0)
.S C=";"_+^PSRX(DA,"STA")_":",X=$P(^DD(52,100,0),"^",3),E=$F(X,C),D=$P($E(X,E,999),";")
"RTN","PSORXPA1",49,0)
.S VALMSG="Prescription is in a "_D_" status."
"RTN","PSORXPA1",50,0)
I $G(PSXSYS),($O(^PS(52.5,"B",DA,""))) S PSOZ1=$O(^PS(52.5,"B",DA,"")) D
"RTN","PSORXPA1",51,0)
.I $P($G(^PS(52.5,PSOZ1,0)),"^",7)="Q"!($P($G(^(0)),"^",7)="L") D
"RTN","PSORXPA1",52,0)
..W !!,"A partial entered for this Rx cannot be suspended."
"RTN","PSORXPA1",53,0)
..W !,"A fill for this Rx is already suspended for CMOP transmission."
"RTN","PSORXPA1",54,0)
..W !,"You may pull this fill from suspense or enter a partial and print the label.",!!
"RTN","PSORXPA1",55,0)
;..S PSOZZ=1 K PSOZ1
"RTN","PSORXPA1",56,0)
CLC S PSOCLC=DUZ,PHYS=$P(^PSRX(DA,0),"^",4),DRG=$P(^(0),"^",6)
"RTN","PSORXPA1",57,0)
I 'PHYS,$O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S PHYS=$S($P(^PSRX(DA,1,I,0),"^",17):$P(^PSRX(DA,1,I,0),"^",17),1:PHYS)
"RTN","PSORXPA1",58,0)
S PSOPRZ=0 I $O(^PSRX(DA,"P",0)) N Z2 F Z2=0:0 S Z2=$O(^PSRX(DA,"P",Z2)) Q:'Z2 S PSOPRZ=Z2
"RTN","PSORXPA1",59,0)
K Z1,PRMK S PM=1,RXN=DA,RXF=6,DIE("NO^")="BACKOUTOK",DIE=52
"RTN","PSORXPA1",60,0)
;DR="[PSO PARTIAL]"
"RTN","PSORXPA1",61,0)
S DR="K PM,PQ;60;Q;S:$O(Y(1))]""""!($G(PM)) Y=""@1"";35;@1;K PM;"
"RTN","PSORXPA1",62,0)
S DR(2,52.2)=".01;S Z1=D1;.02;S:X=""M""!('$P($G(PSOPAR),U,12)) PM=1;.04;S:X=U PQ=1;.041R;S:X=U PQ=1;.05;.07////^S X=DUZ;6////^S X=PHYS;Q;.08///^S X=""NOW"";S PDT=X;.09////^S X=PSOSITE;.03;S:X=U PQ=1;S PRMK=X"
"RTN","PSORXPA1",63,0)
D ^DIE
"RTN","PSORXPA1",64,0)
I $D(RXPR(DA)),'$D(^PSRX(DA,"P",$G(RXPR(DA)))) D RMP^PSOCAN3
"RTN","PSORXPA1",65,0)
G:'$G(Z1) CLCX
"RTN","PSORXPA1",66,0)
I $G(PRMK)']"",Z1>PSOPRZ D ULK G KILL
"RTN","PSORXPA1",67,0)
I Z1,$G(PRMK)]"" D D:$T(EN^PSOHDR)]"" EN^PSOHDR("PPAR",RXN) K DIE,RXN,RXF
"RTN","PSORXPA1",68,0)
.D ACT S:$P($G(^PSRX(RXN,"P",Z1,0)),"^",2)["W" PSODFN=$P(^PSRX(RXN,0),"^",2),BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_RXN_","
"RTN","PSORXPA1",69,0)
.S ZD(RXN)=+^PSRX(RXN,"P",Z1,0),^PSRX(RXN,"TYPE")=Z1,$P(^PSRX(RXN,"P",Z1,0),"^",11)=$P($G(^PSDRUG(DRG,660)),"^",6),RXF=6,RXP=Z1,RXPR(RXN)=RXP
"RTN","PSORXPA1",70,0)
.;I $G(PSOZZ)=1,($G(Z1)) D Q1^PSORXL K Z1,PSOZZ Q
"RTN","PSORXPA1",71,0)
.I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RXN_"," Q
"RTN","PSORXPA1",72,0)
.F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 Q:PSORX("PSOL",PSOX1)[RXN_"," S PSOX2=PSOX1
"RTN","PSORXPA1",73,0)
.I PSOX1 Q
"RTN","PSORXPA1",74,0)
.I $L(PSORX("PSOL",PSOX2))+$L(RXN)<220 S:PSORX("PSOL",PSOX2)'[RXN_"," PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXN_","
"RTN","PSORXPA1",75,0)
.E S PSORX("PSOL",PSOX2+1)=RXN_","
"RTN","PSORXPA1",76,0)
S:('$D(PSOFROM)!$D(^PSRX(DA,"P",Z1,0))) PSOFROM="PARTIAL" S BINGCRT=1 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1
"RTN","PSORXPA1",77,0)
CLCX D ULK K DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ S VALMBCK="R" Q
"RTN","PSORXPA1",78,0)
;
"RTN","PSORXPA1",79,0)
KILL S DA=Z1,DIK="^PSRX("_RXN_",""P""," D ^DIK S ^PSRX(RXN,"TYPE")=0
"RTN","PSORXPA1",80,0)
D ULK S VALMSG="No Partial Fill Dispensed",VALMBCK="R" Q
"RTN","PSORXPA1",81,0)
KL K DFN,RFDAT,RLL,%,PRMK,PM,%Y,%X,D0,D1,DA,DI,DIC,DIE,DLAYGO,DQ,DR,I,II,J,JJJ,N,PHYS,PS,PSDATE,RFL,RFL1,RXF,ST,ST0,Z,Z1,X,Y,PDT,PSL,PSNP
"RTN","PSORXPA1",82,0)
K PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP D KVA^VADPT Q
"RTN","PSORXPA1",83,0)
ACT ;adds activity info for partial rx
"RTN","PSORXPA1",84,0)
S RXF=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1
"RTN","PSORXPA1",85,0)
S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA
"RTN","PSORXPA1",86,0)
S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=DT_"^"_"P"_"^"_DUZ_"^"_RXF_"^"_PRMK
"RTN","PSORXPA1",87,0)
; BNT PSO*7*385 Add audit log entry for TRICARE or CHAMPVA RX
"RTN","PSORXPA1",88,0)
N RXJST
"RTN","PSORXPA1",89,0)
I PSOTRIC!PSOELIG D
"RTN","PSORXPA1",90,0)
. I PSOTRIC S RXJST=$S(PSOTRIC=1:"TRICARE",PSOTRIC=2:"CHAMPVA",1:"")_" Partial Fill"
"RTN","PSORXPA1",91,0)
. I PSOELIG S RXJST=$S(PSOELIG=1:"TRICARE",PSOELIG=2:"CHAMPVA",1:"")_" Partial Fill"
"RTN","PSORXPA1",92,0)
. D AUDIT^PSOTRI(RXN,RXF,,RXJST,"P",$S(PSOTRIC=1:"T",PSOELIG=1:"T",1:"C"))
"RTN","PSORXPA1",93,0)
EX K RXF,I,FDA S DA=RXN
"RTN","PSORXPA1",94,0)
Q
"RTN","PSORXPA1",95,0)
ULK ;
"RTN","PSORXPA1",96,0)
D UL^PSSLOCK(+$G(PSORPDFN))
"RTN","PSORXPA1",97,0)
D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
"RTN","PSORXPA1",98,0)
K PSOMSG,PSOPLCK,PSORPDFN
"RTN","PSORXPA1",99,0)
Q
"RTN","PSOTRI")
0^10^B32068290
"RTN","PSOTRI",1,0)
PSOTRI ;BIRM/BNT - OP TRICARE/CHAMPVA Audit Log Utilities ;07/21/2010
"RTN","PSOTRI",2,0)
;;7.0;OUTPATIENT PHARMACY;**358,385,427,528**;DEC 1997;Build 8
"RTN","PSOTRI",3,0)
;
"RTN","PSOTRI",4,0)
; Reference to DUR1^BPSNCPD3 supported by IA 4560
"RTN","PSOTRI",5,0)
;
"RTN","PSOTRI",6,0)
Q
"RTN","PSOTRI",7,0)
;
"RTN","PSOTRI",8,0)
;
"RTN","PSOTRI",9,0)
AUDIT(RX,RFL,RXCOB,JST,AUD,ELIG) ;
"RTN","PSOTRI",10,0)
; Main entry to create a new record in the PSO AUDIT LOG file #52.87
"RTN","PSOTRI",11,0)
; Note that AUDIT^PSOTRI is called by ECME (BPSECMP2) - ICR 6156
"RTN","PSOTRI",12,0)
; INPUT: RX (r) = Prescription IEN
"RTN","PSOTRI",13,0)
; RFL (o) = Prescription Fill # (Default is original zero fill)
"RTN","PSOTRI",14,0)
; RXCOB (o) = Coordination of Benefits
"RTN","PSOTRI",15,0)
; 1 = Primary (Default)
"RTN","PSOTRI",16,0)
; 2 = Secondary
"RTN","PSOTRI",17,0)
; JST (o) = Justification text
"RTN","PSOTRI",18,0)
; AUD (r) = Audit Type
"RTN","PSOTRI",19,0)
; R = NCPDP REJECT - Associated with an Override audit action
"RTN","PSOTRI",20,0)
; N = NON BILLABLE - Associated with an Override audit action
"RTN","PSOTRI",21,0)
; I = INPATIENT - Associated with a Bypass audit action
"RTN","PSOTRI",22,0)
; P = PARTIAL FILL
"RTN","PSOTRI",23,0)
; ELIG (r) = Eligibility Type
"RTN","PSOTRI",24,0)
; T = TRICARE
"RTN","PSOTRI",25,0)
; C = CHAMPVA
"RTN","PSOTRI",26,0)
; RETURN: Successful Audit entry will return the IEN of the new entry in file 52.87
"RTN","PSOTRI",27,0)
; Unsuccessful Audit entry will return "0^Error Description"
"RTN","PSOTRI",28,0)
;
"RTN","PSOTRI",29,0)
N PSOTRIC,PSODIV,RXFLDS,RFLFLDS,RXECME,PSOFDA,FN,SFN,PSOIEN,PSOIENS,PSOUSER,PSOTC,PSOET
"RTN","PSOTRI",30,0)
N I,PSOAIEN,PSOREJ,DFN,PSODOA,PSODOS,PSOERR,PSOX,PSOY,RXARR,RFLARR,PSOPHRM,PSOQTY
"RTN","PSOTRI",31,0)
N PDDATE,PFARR,PFFLDS,PFIEN,PSOPFIEN,PSOUNITCOST
"RTN","PSOTRI",32,0)
;
"RTN","PSOTRI",33,0)
Q:'$D(^PSRX(RX,0)) "0^Prescription does not exist"
"RTN","PSOTRI",34,0)
; Verify refill exists
"RTN","PSOTRI",35,0)
I RFL=""!RFL<0 S RFL=$$LSTRFL^PSOBPSU1(RX)
"RTN","PSOTRI",36,0)
;
"RTN","PSOTRI",37,0)
; Not original fill
"RTN","PSOTRI",38,0)
I RFL Q:'$D(^PSRX(RX,1,RFL)) "0^Refill "_RFL_" does not exist"
"RTN","PSOTRI",39,0)
;
"RTN","PSOTRI",40,0)
; Verify eligibility exists
"RTN","PSOTRI",41,0)
Q:ELIG="" "0^Eligibiltiy does not exist"
"RTN","PSOTRI",42,0)
;
"RTN","PSOTRI",43,0)
; Verify Eligibility Type - TRICARE or CHAMPVA patient
"RTN","PSOTRI",44,0)
I ("/T/C/")'[("/"_ELIG_"/") Q "0^Invalid Eligibility Type "_ELIG
"RTN","PSOTRI",45,0)
; PSOTRIC is used below to determine if there is a eT or eC reject code
"RTN","PSOTRI",46,0)
S (PSOTRIC,PSOTC)="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
"RTN","PSOTRI",47,0)
;
"RTN","PSOTRI",48,0)
; Verify Audit Type
"RTN","PSOTRI",49,0)
I ("/R/N/I/P/")'[("/"_AUD_"/") Q "0^Invalid Audit Type "_AUD
"RTN","PSOTRI",50,0)
;
"RTN","PSOTRI",51,0)
; Coordination of Benefits (default is Primary)
"RTN","PSOTRI",52,0)
S RXCOB=+$G(RXCOB) I RXCOB=0 S RXCOB=1
"RTN","PSOTRI",53,0)
; Audit File and Reject subfile
"RTN","PSOTRI",54,0)
S FN=52.87,SFN=52.8713
"RTN","PSOTRI",55,0)
;
"RTN","PSOTRI",56,0)
; Fields for original fill:
"RTN","PSOTRI",57,0)
; PROVIDER;NDC;DRUG NAME;QUANTITY;PATIENT;PATIENT STATUS;PHARMACIST;UNIT PRICE OF DRUG
"RTN","PSOTRI",58,0)
S RXFLDS="4;27;6;7;2;3;23;17"
"RTN","PSOTRI",59,0)
; Fields for refills
"RTN","PSOTRI",60,0)
; PROVIDER;NDC;QUANTITY;PHARMACIST
"RTN","PSOTRI",61,0)
S RFLFLDS="15;11;1;4"
"RTN","PSOTRI",62,0)
;
"RTN","PSOTRI",63,0)
; Get data from RX
"RTN","PSOTRI",64,0)
D GETS^DIQ(52,RX,RXFLDS,"I","RXARR")
"RTN","PSOTRI",65,0)
; Get data from Refill
"RTN","PSOTRI",66,0)
I RFL D GETS^DIQ(52.1,RFL_","_RX,RFLFLDS,"I","RFLARR")
"RTN","PSOTRI",67,0)
; Get Division
"RTN","PSOTRI",68,0)
S PSODIV=$$RXSITE^PSOBPSUT(RX,RFL)
"RTN","PSOTRI",69,0)
; ECME Number, if exists
"RTN","PSOTRI",70,0)
S RXECME=$$ECMENUM^PSOBPSU2(RX,RFL)
"RTN","PSOTRI",71,0)
; Date of Action is NOW
"RTN","PSOTRI",72,0)
S PSODOA=$$NOW^XLFDT()
"RTN","PSOTRI",73,0)
; Date of Service
"RTN","PSOTRI",74,0)
S PSODOS=$$DOS^PSOBPSU1(RX,RFL)
"RTN","PSOTRI",75,0)
; User (If null OR Audit Type is Inpatient OR bypass-type reject, set to POSTMASTER)
"RTN","PSOTRI",76,0)
S PSOUSER=DUZ
"RTN","PSOTRI",77,0)
I (PSOUSER="")!(AUD="I")!$$BYPASS^PSOBPSU1(ELIG,JST) S PSOUSER=.5
"RTN","PSOTRI",78,0)
; Set up FDA array
"RTN","PSOTRI",79,0)
S PSOIEN="+1,"
"RTN","PSOTRI",80,0)
S PSOAIEN=$P($G(^PS(52.87,0)),U,3)+1
"RTN","PSOTRI",81,0)
;
"RTN","PSOTRI",82,0)
; Quantity, Provider and NDC fields
"RTN","PSOTRI",83,0)
I AUD="P" D
"RTN","PSOTRI",84,0)
. ; For Partial Fills pull the QTY, PROVIDER and NDC and from
"RTN","PSOTRI",85,0)
. ; the appropriate entry in the PARTIAL DATE sub-file #52.2.
"RTN","PSOTRI",86,0)
. ; Attempt to identify a partial fill for today's date.
"RTN","PSOTRI",87,0)
. S PSOPFIEN=""
"RTN","PSOTRI",88,0)
. S PFIEN=0 F S PFIEN=$O(^PSRX(RX,"P",PFIEN)) Q:'PFIEN S PDDATE=$P($G(^PSRX(RX,"P",PFIEN,0)),U,8) I $P(PDDATE,".")=$P(PSODOA,".") S PSOPFIEN=PFIEN
"RTN","PSOTRI",89,0)
. ; partial fill entry for today not found
"RTN","PSOTRI",90,0)
. I 'PSOPFIEN Q
"RTN","PSOTRI",91,0)
. ;
"RTN","PSOTRI",92,0)
. ;QTY;CURRENT UNIT PRICE OF DRUG;PROVIDER;NDC
"RTN","PSOTRI",93,0)
. S PFFLDS=".04;.042;6;1"
"RTN","PSOTRI",94,0)
. D GETS^DIQ(52.2,PSOPFIEN_","_RX,PFFLDS,"I","PFARR")
"RTN","PSOTRI",95,0)
. S PSOQTY=$G(PFARR(52.2,PSOPFIEN_","_RX_",",.04,"I"))
"RTN","PSOTRI",96,0)
. ;Get the UNIT PRICE OF DRUG from the Prescription, the UNIT PRICE isn't stored
"RTN","PSOTRI",97,0)
. ; with the partial fill until later in the processing.
"RTN","PSOTRI",98,0)
. S PSOUNITCOST=$G(RXARR(52,RX_",",17,"I"))
"RTN","PSOTRI",99,0)
. ; PROVIDER field
"RTN","PSOTRI",100,0)
. S PSOFDA(FN,PSOIEN,5)=$G(PFARR(52.2,PSOPFIEN_","_RX_",",6,"I"))
"RTN","PSOTRI",101,0)
. ; NDC field
"RTN","PSOTRI",102,0)
. S PSOFDA(FN,PSOIEN,6)=$G(PFARR(52.2,PSOPFIEN_","_RX_",",1,"I"))
"RTN","PSOTRI",103,0)
. I PSOFDA(FN,PSOIEN,6)'="" S PSOFDA(FN,PSOIEN,6)=$G(RXARR(52,RX_",",27,"I"))
"RTN","PSOTRI",104,0)
. ; BILL COST field
"RTN","PSOTRI",105,0)
. S PSOFDA(FN,PSOIEN,8)=(PSOUNITCOST*PSOQTY)+8
"RTN","PSOTRI",106,0)
E D
"RTN","PSOTRI",107,0)
. S PSOQTY=$S(RFL>0:$G(RFLARR(52.1,RFL_","_RX_",",1,"I")),1:$G(RXARR(52,RX_",",7,"I")))
"RTN","PSOTRI",108,0)
. ; PROVIDER field
"RTN","PSOTRI",109,0)
. S PSOFDA(FN,PSOIEN,5)=$S(RFL>0:$G(RFLARR(52.1,RFL_","_RX_",",15,"I")),1:$G(RXARR(52,RX_",",4,"I")))
"RTN","PSOTRI",110,0)
. ; NDC field
"RTN","PSOTRI",111,0)
. S PSOFDA(FN,PSOIEN,6)=$S(RFL>0:$G(RFLARR(52.1,RFL_","_RX_",",11,"I")),1:$G(RXARR(52,RX_",",27,"I")))
"RTN","PSOTRI",112,0)
. ; BILL COST field
"RTN","PSOTRI",113,0)
. S PSOFDA(FN,PSOIEN,8)=$G(RXARR(52,RX_",",17,"I"))*PSOQTY+8 ;This needs to be verified
"RTN","PSOTRI",114,0)
;
"RTN","PSOTRI",115,0)
; AUDIT ID field
"RTN","PSOTRI",116,0)
S PSOFDA(FN,PSOIEN,.01)=PSOAIEN
"RTN","PSOTRI",117,0)
; PRESCRIPTION field
"RTN","PSOTRI",118,0)
S PSOFDA(FN,PSOIEN,1)=RX
"RTN","PSOTRI",119,0)
; FILL field
"RTN","PSOTRI",120,0)
S PSOFDA(FN,PSOIEN,2)=RFL
"RTN","PSOTRI",121,0)
; PATIENT field
"RTN","PSOTRI",122,0)
S PSOFDA(FN,PSOIEN,3)=$G(RXARR(52,RX_",",2,"I"))
"RTN","PSOTRI",123,0)
; DIVISION field
"RTN","PSOTRI",124,0)
S PSOFDA(FN,PSOIEN,4)=PSODIV
"RTN","PSOTRI",125,0)
; DRUG field
"RTN","PSOTRI",126,0)
S PSOFDA(FN,PSOIEN,7)=$G(RXARR(52,RX_",",6,"I"))
"RTN","PSOTRI",127,0)
; ECME NUMBER field
"RTN","PSOTRI",128,0)
S PSOFDA(FN,PSOIEN,9)=RXECME
"RTN","PSOTRI",129,0)
; QTY field
"RTN","PSOTRI",130,0)
S PSOFDA(FN,PSOIEN,10)=PSOQTY
"RTN","PSOTRI",131,0)
; PATIENT STATUS field
"RTN","PSOTRI",132,0)
S PSOFDA(FN,PSOIEN,11)=$G(RXARR(52,RX_",",3,"I"))
"RTN","PSOTRI",133,0)
; AUDIT TYPE field
"RTN","PSOTRI",134,0)
S PSOFDA(FN,PSOIEN,12)=AUD
"RTN","PSOTRI",135,0)
; USER field
"RTN","PSOTRI",136,0)
S PSOFDA(FN,PSOIEN,14)=PSOUSER
"RTN","PSOTRI",137,0)
; DATE OF ACTION field
"RTN","PSOTRI",138,0)
S PSOFDA(FN,PSOIEN,15)=PSODOA
"RTN","PSOTRI",139,0)
; DATE OF SERVICE field
"RTN","PSOTRI",140,0)
S PSOFDA(FN,PSOIEN,16)=PSODOS
"RTN","PSOTRI",141,0)
; TRICARE JUSTIFICATION field
"RTN","PSOTRI",142,0)
S PSOFDA(FN,PSOIEN,17)=JST
"RTN","PSOTRI",143,0)
; Eligibility Code
"RTN","PSOTRI",144,0)
S PSOFDA(FN,PSOIEN,18)=ELIG
"RTN","PSOTRI",145,0)
;
"RTN","PSOTRI",146,0)
D DUR1^BPSNCPD3(RX,RFL,.PSOREJ,.PSOERR,RXCOB)
"RTN","PSOTRI",147,0)
S PSOET=$$PSOET^PSOREJP3(RX,RFL) ;check to see if eT or eC is the reject code as no ecme claim.
"RTN","PSOTRI",148,0)
I PSOET S PSOTC=$S(PSOTRIC=1:"eT",PSOTRIC=2:"eC",1:"")
"RTN","PSOTRI",149,0)
I PSOTC]"",'$D(PSOREJ(RXCOB,"REJ CODES")) S PSOREJ(RXCOB,"REJ CODES",1,PSOTC)="",PSOREJ(RXCOB,"REJ CODE LST")=PSOTC
"RTN","PSOTRI",150,0)
I $G(PSOREJ(RXCOB,"REJ CODE LST"))]"" D
"RTN","PSOTRI",151,0)
. S PSOX="",PSOY=1 F I=1:1 S PSOX=$O(PSOREJ(RXCOB,"REJ CODES",I,0)) Q:PSOX="" D
"RTN","PSOTRI",152,0)
. . S PSOY=PSOY+1,PSOIENS=PSOY_","_PSOIEN
"RTN","PSOTRI",153,0)
. . S PSOFDA(SFN,"+"_PSOIENS,.01)=PSOX
"RTN","PSOTRI",154,0)
;
"RTN","PSOTRI",155,0)
D UPDATE^DIE("","PSOFDA","","PSOERR")
"RTN","PSOTRI",156,0)
I $D(PSOERR("DIERR")) D BMES^XPDUTL(PSOERR("DIERR",1,"TEXT",1))
"RTN","PSOTRI",157,0)
Q
"VER")
8.0^22.2
**INSTALL NAME**
IB*2.0*624
"BLD",11108,0)
IB*2.0*624^INTEGRATED BILLING^0^3190319^y
"BLD",11108,4,0)
^9.64PA^^
"BLD",11108,6.3)
8
"BLD",11108,"KRN",0)
^9.67PA^779.2^20
"BLD",11108,"KRN",.4,0)
.4
"BLD",11108,"KRN",.401,0)
.401
"BLD",11108,"KRN",.402,0)
.402
"BLD",11108,"KRN",.403,0)
.403
"BLD",11108,"KRN",.5,0)
.5
"BLD",11108,"KRN",.84,0)
.84
"BLD",11108,"KRN",3.6,0)
3.6
"BLD",11108,"KRN",3.8,0)
3.8
"BLD",11108,"KRN",9.2,0)
9.2
"BLD",11108,"KRN",9.8,0)
9.8
"BLD",11108,"KRN",9.8,"NM",0)
^9.68A^7^7
"BLD",11108,"KRN",9.8,"NM",1,0)
IBNCPDPU^^0^B133189432
"BLD",11108,"KRN",9.8,"NM",2,0)
IBNCPDP1^^0^B184856569
"BLD",11108,"KRN",9.8,"NM",3,0)
IBCBB14^^0^B6422089
"BLD",11108,"KRN",9.8,"NM",4,0)
IBNCPBB^^0^B100415567
"BLD",11108,"KRN",9.8,"NM",5,0)
IBNCPBB1^^0^B5603763
"BLD",11108,"KRN",9.8,"NM",6,0)
IBNCPDR4^^0^B37656873
"BLD",11108,"KRN",9.8,"NM",7,0)
IBTRKR3^^0^B59891059
"BLD",11108,"KRN",9.8,"NM","B","IBCBB14",3)

"BLD",11108,"KRN",9.8,"NM","B","IBNCPBB",4)

"BLD",11108,"KRN",9.8,"NM","B","IBNCPBB1",5)

"BLD",11108,"KRN",9.8,"NM","B","IBNCPDP1",2)

"BLD",11108,"KRN",9.8,"NM","B","IBNCPDPU",1)

"BLD",11108,"KRN",9.8,"NM","B","IBNCPDR4",6)

"BLD",11108,"KRN",9.8,"NM","B","IBTRKR3",7)

"BLD",11108,"KRN",19,0)
19
"BLD",11108,"KRN",19.1,0)
19.1
"BLD",11108,"KRN",101,0)
101
"BLD",11108,"KRN",409.61,0)
409.61
"BLD",11108,"KRN",771,0)
771
"BLD",11108,"KRN",779.2,0)
779.2
"BLD",11108,"KRN",870,0)
870
"BLD",11108,"KRN",8989.51,0)
8989.51
"BLD",11108,"KRN",8989.52,0)
8989.52
"BLD",11108,"KRN",8994,0)
8994
"BLD",11108,"KRN","B",.4,.4)

"BLD",11108,"KRN","B",.401,.401)

"BLD",11108,"KRN","B",.402,.402)

"BLD",11108,"KRN","B",.403,.403)

"BLD",11108,"KRN","B",.5,.5)

"BLD",11108,"KRN","B",.84,.84)

"BLD",11108,"KRN","B",3.6,3.6)

"BLD",11108,"KRN","B",3.8,3.8)

"BLD",11108,"KRN","B",9.2,9.2)

"BLD",11108,"KRN","B",9.8,9.8)

"BLD",11108,"KRN","B",19,19)

"BLD",11108,"KRN","B",19.1,19.1)

"BLD",11108,"KRN","B",101,101)

"BLD",11108,"KRN","B",409.61,409.61)

"BLD",11108,"KRN","B",771,771)

"BLD",11108,"KRN","B",779.2,779.2)

"BLD",11108,"KRN","B",870,870)

"BLD",11108,"KRN","B",8989.51,8989.51)

"BLD",11108,"KRN","B",8989.52,8989.52)

"BLD",11108,"KRN","B",8994,8994)

"BLD",11108,"QUES",0)
^9.62^^
"MBREQ")
1
"PKG",230,-1)
1^1
"PKG",230,0)
INTEGRATED BILLING^IB^INTEGRATED BILLING
"PKG",230,22,0)
^9.49I^1^1
"PKG",230,22,1,0)
2.0^2940321^2940525
"PKG",230,22,1,"PAH",1,0)
624^3190319
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
7
"RTN","IBCBB14")
0^3^B6422089
"RTN","IBCBB14",1,0)
IBCBB14 ;ALB/WCJ - CONTINUATION OF EDIT CHECK ROUTINE FOR EPHARM ;15 Mar 2018 9:50 PM
"RTN","IBCBB14",2,0)
;;2.0;INTEGRATED BILLING;**591,592,624**;21-MAR-94;Build 8
"RTN","IBCBB14",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBCBB14",4,0)
;
"RTN","IBCBB14",5,0)
Q
"RTN","IBCBB14",6,0)
VALNDC(IBIFN,IBDFN) ; IB*2*363 - validate NDC# between PRESCRIPTION file (#52)
"RTN","IBCBB14",7,0)
; and IB BILL/CLAIMS PRESCRIPTION REFILL file (#362.4)
"RTN","IBCBB14",8,0)
; input - IBIFN = internal entry number of the billing record in the BILL/CLAIMS file (#399)
"RTN","IBCBB14",9,0)
; IBDFN = internal entry number of patient record in the PATIENT file (#2)
"RTN","IBCBB14",10,0)
N IBX,IBRXCOL
"RTN","IBCBB14",11,0)
; call program that determines if NDC differences exist
"RTN","IBCBB14",12,0)
D VALNDC^IBEFUNC3(IBIFN,IBDFN,.IBRXCOL)
"RTN","IBCBB14",13,0)
Q:'$D(IBRXCOL)
"RTN","IBCBB14",14,0)
; at least one RX on the IB record has an NDC discrepancy
"RTN","IBCBB14",15,0)
S IBX=0 F S IBX=$O(IBRXCOL(IBX)) Q:'IBX D WARN^IBCBB11("NDC# on Bill does not equal the NDC# on Rx "_IBRXCOL(IBX))
"RTN","IBCBB14",16,0)
Q
"RTN","IBCBB14",17,0)
;
"RTN","IBCBB14",18,0)
RXNPI(IBIFN) ; check for multiple pharmacy npi's on the same bill
"RTN","IBCBB14",19,0)
N IBORG,IBRXNPI,IBX,IBY
"RTN","IBCBB14",20,0)
S IBORG=$$RXSITE^IBCEF73A(IBIFN,.IBORG)
"RTN","IBCBB14",21,0)
S IBX=0 F S IBX=$O(IBORG(IBX)) Q:'IBX S IBY=0 F S IBY=$O(IBORG(IBX,IBY)) Q:'IBY S IBRXNPI(+IBORG(IBX,IBY))=""
"RTN","IBCBB14",22,0)
S (IBX,IBY)=0 F S IBX=$O(IBRXNPI(IBX)) Q:'IBX S IBY=IBY+1
"RTN","IBCBB14",23,0)
I IBY>1 D WARN^IBCBB11("Bill has prescriptions resulting from "_IBY_" different NPI locations")
"RTN","IBCBB14",24,0)
Q
"RTN","IBCBB14",25,0)
;
"RTN","IBCBB14",26,0)
ROICHK(IBIFN,IBDFN,IBINS) ; IB*2.0*384 - check prescriptions that contain the
"RTN","IBCBB14",27,0)
; SENSITIVE DIAGNOSIS DRUG field #87 in the DRUG File #50 set to 1 against
"RTN","IBCBB14",28,0)
; the Claims Tracking ROI file (#356.25) to see if an ROI is on file, or if the
"RTN","IBCBB14",29,0)
; Date of Service is on or after the Mission Act Implementation Date (1/28/2019)
"RTN","IBCBB14",30,0)
; input - IBIFN = IEN of the Bill/Claims file (#399)
"RTN","IBCBB14",31,0)
; IBDFN = IEN of the patient
"RTN","IBCBB14",32,0)
; IBINS = IEN of the payer insurance company (#36)
"RTN","IBCBB14",33,0)
; OUTPUT - 0 = no error
"RTN","IBCBB14",34,0)
; 1 = a prescription is sensitive and there is no ROI on file
"RTN","IBCBB14",35,0)
;
"RTN","IBCBB14",36,0)
N IBX,IBY0,IBRXIEN,IBDT,IBDRUG,ROIQ
"RTN","IBCBB14",37,0)
S ROIQ=0
"RTN","IBCBB14",38,0)
S IBX=0 F S IBX=$O(^IBA(362.4,"C",IBIFN,IBX)) Q:'IBX D
"RTN","IBCBB14",39,0)
.S IBY0=^IBA(362.4,IBX,0),IBRXIEN=$P(IBY0,U,5) I 'IBRXIEN Q
"RTN","IBCBB14",40,0)
.S IBDT=$P(IBY0,U,3),IBDRUG=$P(IBY0,U,4)
"RTN","IBCBB14",41,0)
.D ZERO^IBRXUTL(IBDRUG)
"RTN","IBCBB14",42,0)
.I $$SENS^IBNCPDR(IBDRUG) D ; Sensitive Diagnosis Drug - check for ROI
"RTN","IBCBB14",43,0)
.. ; Check to see if the Date of Service (DOS) is prior to the Mission Act Implementation Date
"RTN","IBCBB14",44,0)
.. ; If the DOS is on or after the Mission Act Date don't perform ROI checks
"RTN","IBCBB14",45,0)
.. I $$MACHK^IBNCPDR4(IBDT) Q
"RTN","IBCBB14",46,0)
.. I $$ROI^IBNCPDR4(IBDFN,IBDRUG,IBINS,IBDT) Q ;ROI is on file
"RTN","IBCBB14",47,0)
.. D WARN^IBCBB11("ROI not on file for prescription "_$$RXAPI1^IBNCPUT1(IBRXIEN,.01,"E"))
"RTN","IBCBB14",48,0)
.. S ROIQ=1
"RTN","IBCBB14",49,0)
ROICHKQ ;
"RTN","IBCBB14",50,0)
K ^TMP($J,"IBDRUG")
"RTN","IBCBB14",51,0)
Q ROIQ
"RTN","IBCBB14",52,0)
;
"RTN","IBNCPBB")
0^4^B100415567
"RTN","IBNCPBB",1,0)
IBNCPBB ;DALOI/AAT - ECME BACKBILLING ;24-JUN-2003
"RTN","IBNCPBB",2,0)
;;2.0;INTEGRATED BILLING;**276,347,384,435,575,624**;21-MAR-94;Build 8
"RTN","IBNCPBB",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBNCPBB",4,0)
;
"RTN","IBNCPBB",5,0)
; Reference to file #9002313.29 supported by IA# 4222
"RTN","IBNCPBB",6,0)
; Reference to DIC^PSODI supported by IA# 4858
"RTN","IBNCPBB",7,0)
;
"RTN","IBNCPBB",8,0)
Q
"RTN","IBNCPBB",9,0)
EN ;[IB GENERATE ECME RX BILLS] entry
"RTN","IBNCPBB",10,0)
N IBMOD1,IBMOD3,IBPAT,IBRX,IBBDT,IBEDT,IBSEL,IBREF,IBPAUSE
"RTN","IBNCPBB",11,0)
S IBREF=$NA(^TMP($J,"IBNCPBB"))
"RTN","IBNCPBB",12,0)
S IBPAUSE=1
"RTN","IBNCPBB",13,0)
K @IBREF D
"RTN","IBNCPBB",14,0)
. N IBEXIT
"RTN","IBNCPBB",15,0)
. S IBEXIT=0
"RTN","IBNCPBB",16,0)
. D MODE I IBEXIT Q
"RTN","IBNCPBB",17,0)
. I IBMOD1="P" D SELECT I IBEXIT Q
"RTN","IBNCPBB",18,0)
. I IBMOD1="R" D SELECT2 I IBEXIT Q
"RTN","IBNCPBB",19,0)
. D CONFIRM I IBEXIT Q
"RTN","IBNCPBB",20,0)
. D PROCESS^IBNCPBB1 I IBEXIT Q
"RTN","IBNCPBB",21,0)
I IBPAUSE W ! D PAUSE()
"RTN","IBNCPBB",22,0)
K @IBREF
"RTN","IBNCPBB",23,0)
Q
"RTN","IBNCPBB",24,0)
;
"RTN","IBNCPBB",25,0)
CT(IBTRN) ;CT ENTRY
"RTN","IBNCPBB",26,0)
N IBBIL,IBBN,IBDELAY,IBEXIT,IBERR,IBFDT,IBFIL,IBPAT,IBQ,IBRDT,IBRES,IBROIMA,IBRX,IBRXN,IBSCRES,IBZ
"RTN","IBNCPBB",27,0)
S IBQ=0
"RTN","IBNCPBB",28,0)
D FULL^VALM1
"RTN","IBNCPBB",29,0)
W !!,"This option sends electronic Pharmacy Claims to the Payer"
"RTN","IBNCPBB",30,0)
S VALMBCK="R"
"RTN","IBNCPBB",31,0)
S IBZ=$G(^IBT(356,IBTRN,0)) Q:IBZ=""
"RTN","IBNCPBB",32,0)
S IBRX=$P(IBZ,U,8),IBFIL=$P(IBZ,U,10)
"RTN","IBNCPBB",33,0)
I 'IBRX D Q
"RTN","IBNCPBB",34,0)
. W !!,"This is not a Pharmacy Claims Tracking record",*7,!
"RTN","IBNCPBB",35,0)
. D PAUSE("Cannot submit to ECME")
"RTN","IBNCPBB",36,0)
;
"RTN","IBNCPBB",37,0)
;Release date:
"RTN","IBNCPBB",38,0)
I IBFIL=0 S IBRDT=$$FILE^IBRXUTL(IBRX,31)
"RTN","IBNCPBB",39,0)
E S IBRDT=$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,17)
"RTN","IBNCPBB",40,0)
I 'IBRDT D Q
"RTN","IBNCPBB",41,0)
. W !!,"The Prescription is not released.",!
"RTN","IBNCPBB",42,0)
. D PAUSE("Cannot submit to ECME")
"RTN","IBNCPBB",43,0)
; -- Drug DEA ROI check.
"RTN","IBNCPBB",44,0)
S IBPAT=$P(IBZ,U,2)
"RTN","IBNCPBB",45,0)
S IBDRUG=$$FILE^IBRXUTL(IBRX,6)
"RTN","IBNCPBB",46,0)
; Fill/Refill Date:
"RTN","IBNCPBB",47,0)
S IBFDT=$S('IBFIL:$$FILE^IBRXUTL(IBRX,22),1:$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,.01))
"RTN","IBNCPBB",48,0)
I $$INSUR^IBBAPI(IBPAT,IBFDT,"P",.IBANY,1) D I 'IBQ D PAUSE() Q ;Requires ROI
"RTN","IBNCPBB",49,0)
. S IBINS=+$G(IBANY("IBBAPI","INSUR",1,1))
"RTN","IBNCPBB",50,0)
. ; if the Date of Service is on or after the Mission Act Implementation Date
"RTN","IBNCPBB",51,0)
. ; don't check for ROI on file and set IBQ=1
"RTN","IBNCPBB",52,0)
. S IBROIMA=$$MACHK^IBNCPDR4(IBFDT) S IBQ=1
"RTN","IBNCPBB",53,0)
. ; If there's an ROI on file (IBQ=1) then D ROICLN^IBNCPDR4
"RTN","IBNCPBB",54,0)
. I 'IBROIMA S IBQ=$$ROICHK^IBNCPDR4(IBPAT,IBDRUG,IBINS,IBFDT)
"RTN","IBNCPBB",55,0)
. I IBQ=1 D ROICLN^IBNCPDR4(IBTRN)
"RTN","IBNCPBB",56,0)
. Q
"RTN","IBNCPBB",57,0)
;
"RTN","IBNCPBB",58,0)
S IBQ=0 I $$SC($P(IBZ,U,19)) D Q:IBQ ;575: Reset IBQ flag to 0
"RTN","IBNCPBB",59,0)
. N DIR,DIE,DA,DR,Y
"RTN","IBNCPBB",60,0)
. W !!,"The Rx is marked 'non-billable' in CT: ",$P($G(^IBE(356.8,+$P(IBZ,U,19),0)),U)
"RTN","IBNCPBB",61,0)
. W !,"If you continue, the NON-BILLABLE REASON will be deleted.",!
"RTN","IBNCPBB",62,0)
. S DIR(0)="Y",DIR("A")="Are you sure you want to bill this episode"
"RTN","IBNCPBB",63,0)
. S DIR("B")="NO"
"RTN","IBNCPBB",64,0)
. S DIR("?")="If you want to bill this Rx, enter 'Yes' - otherwise, enter 'No'"
"RTN","IBNCPBB",65,0)
. W ! D ^DIR K DIR
"RTN","IBNCPBB",66,0)
. I 'Y S IBQ=1 Q
"RTN","IBNCPBB",67,0)
. S DIE="^IBT(356,",DA=IBTRN,DR=".19///@" D ^DIE ;clean NB reason
"RTN","IBNCPBB",68,0)
. S IBSCRES(IBRX,IBFIL)=1 ; sc resolved flag
"RTN","IBNCPBB",69,0)
;
"RTN","IBNCPBB",70,0)
S IBZ=$G(^IBT(356,IBTRN,0)) ; refresh
"RTN","IBNCPBB",71,0)
I $P(IBZ,U,19) D Q
"RTN","IBNCPBB",72,0)
. W !!,"The Prescription is marked 'non-billable' in Claims Tracking",*7
"RTN","IBNCPBB",73,0)
. W !,"Reason non-billable: ",$P($G(^IBE(356.8,+$P(IBZ,U,19),0),"Unknown"),U),!
"RTN","IBNCPBB",74,0)
. D PAUSE("Cannot submit to ECME")
"RTN","IBNCPBB",75,0)
; Is the patient billable at the released date?
"RTN","IBNCPBB",76,0)
S IBRES=$$ECMEBIL^IBNCPDPU(IBPAT,IBFDT)
"RTN","IBNCPBB",77,0)
I 'IBRES D Q
"RTN","IBNCPBB",78,0)
. W !!,"The patient is not ECME Billable at the ",$S(IBFIL:"re",1:""),"fill date."
"RTN","IBNCPBB",79,0)
. W !,"Reason: ",$P(IBRES,U,2,255),!
"RTN","IBNCPBB",80,0)
. D PAUSE("Cannot submit to ECME")
"RTN","IBNCPBB",81,0)
;
"RTN","IBNCPBB",82,0)
S IBRXN=$$FILE^IBRXUTL(IBRX,.01)
"RTN","IBNCPBB",83,0)
S IBBIL=$$BILL(IBRXN,IBRDT)
"RTN","IBNCPBB",84,0)
I IBBIL,'$P($G(^DGCR(399,IBBIL,"S")),U,16) D Q
"RTN","IBNCPBB",85,0)
. W !!,"Rx# ",IBRXN," was previously billed."
"RTN","IBNCPBB",86,0)
. W !,"Please manually cancel the bill# ",$P($G(^DGCR(399,IBBIL,0)),U)," before submitting claim to ECME.",!
"RTN","IBNCPBB",87,0)
. D PAUSE("Cannot submit to ECME")
"RTN","IBNCPBB",88,0)
I IBBIL W !,"The bill# ",$P($G(^DGCR(399,IBBIL,0)),U)," has been cancelled.",!
"RTN","IBNCPBB",89,0)
;
"RTN","IBNCPBB",90,0)
S IBDELAY=$$DLYRC() ; get delay reason code with optional parameter, IB*2.0*435
"RTN","IBNCPBB",91,0)
;
"RTN","IBNCPBB",92,0)
D CONFRX(IBRXN) Q:$G(IBEXIT)
"RTN","IBNCPBB",93,0)
;
"RTN","IBNCPBB",94,0)
W !!,"Submitting Rx# ",IBRXN W:IBFIL ", Refill# ",IBFIL W " ..."
"RTN","IBNCPBB",95,0)
S IBRES=$$SUBMIT^IBNCPDPU(IBRX,IBFIL,IBDELAY) W !," ",$S(+IBRES=0:"S",1:"Not s")_"ent through ECME."
"RTN","IBNCPBB",96,0)
I +IBRES'=0 W !," *** ECME returned status: ",$$STAT(IBRES),!
"RTN","IBNCPBB",97,0)
I +IBRES=0 W !!,"The Rx have been submitted to ECME for electronic billing",!
"RTN","IBNCPBB",98,0)
D PAUSE()
"RTN","IBNCPBB",99,0)
Q
"RTN","IBNCPBB",100,0)
;
"RTN","IBNCPBB",101,0)
MODE ;
"RTN","IBNCPBB",102,0)
; IBMOD1: "P"-Single Patient, "R"-Single Rx
"RTN","IBNCPBB",103,0)
; IBMOD3 (if IBMOD1="P"): "U"-Unbilled, "A"-All Rx
"RTN","IBNCPBB",104,0)
; IBPAT (if IBMOD1="P"): Patient's DFN
"RTN","IBNCPBB",105,0)
; IBBDT,IBEDT (if IBMOD1="P"): From/To dates inclusive
"RTN","IBNCPBB",106,0)
N DIR,DIC,DIRUT,DUOUT,Y,PSOFILE
"RTN","IBNCPBB",107,0)
S (IBMOD1,IBMOD3)=""
"RTN","IBNCPBB",108,0)
S DIR(0)="S^P:SINGLE (P)ATIENT;R:SINGLE (R)X"
"RTN","IBNCPBB",109,0)
S DIR("A")="SINGLE (P)ATIENT, SINGLE (R)X"
"RTN","IBNCPBB",110,0)
S DIR("B")="P"
"RTN","IBNCPBB",111,0)
D ^DIR K DIR I $D(DIRUT) S IBEXIT=1,IBPAUSE=0 Q
"RTN","IBNCPBB",112,0)
S IBMOD1=Y
"RTN","IBNCPBB",113,0)
; Enter Rx
"RTN","IBNCPBB",114,0)
I IBMOD1="R" W ! S PSOFILE=52,DIC="^PSRX(",DIC(0)="AEQMN" D DIC^PSODI(PSOFILE,.DIC) S:$D(DUOUT) IBEXIT=1 S IBRX=$S(Y>0:+Y,1:0) S:'IBRX IBEXIT=1,IBPAUSE=0
"RTN","IBNCPBB",115,0)
K PSODIY
"RTN","IBNCPBB",116,0)
I IBMOD1="R" Q
"RTN","IBNCPBB",117,0)
;
"RTN","IBNCPBB",118,0)
I IBMOD1'="P" W !,"???" S IBEXIT=1 Q ; Invalid mode
"RTN","IBNCPBB",119,0)
;Enter Patient
"RTN","IBNCPBB",120,0)
S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC S:$D(DUOUT) IBEXIT=1 S IBPAT=$S(Y>0:+Y,1:0) S:'IBPAT IBEXIT=1,IBPAUSE=0
"RTN","IBNCPBB",121,0)
Q:IBEXIT
"RTN","IBNCPBB",122,0)
I '$$ECMEBIL^IBNCPDPU(IBPAT,DT) W *7,!!,"Warning! The patient is currently not ECME billable!"
"RTN","IBNCPBB",123,0)
;
"RTN","IBNCPBB",124,0)
D DATE I IBEXIT S IBPAUSE=0 Q
"RTN","IBNCPBB",125,0)
;
"RTN","IBNCPBB",126,0)
S DIR(0)="S^U:UNBILLED;A:ALL RX"
"RTN","IBNCPBB",127,0)
S DIR("A")="(U)NBILLED, (A)LL RX"
"RTN","IBNCPBB",128,0)
S DIR("B")="U"
"RTN","IBNCPBB",129,0)
D ^DIR K DIR I $D(DIRUT) S IBEXIT=1,IBPAUSE=0 Q
"RTN","IBNCPBB",130,0)
S IBMOD3=Y
"RTN","IBNCPBB",131,0)
Q
"RTN","IBNCPBB",132,0)
;
"RTN","IBNCPBB",133,0)
;begin/end date
"RTN","IBNCPBB",134,0)
DATE ;
"RTN","IBNCPBB",135,0)
N Y,%DT
"RTN","IBNCPBB",136,0)
S (IBBDT,IBEDT)=DT
"RTN","IBNCPBB",137,0)
W !
"RTN","IBNCPBB",138,0)
S %DT="AEX"
"RTN","IBNCPBB",139,0)
S %DT("A")="START WITH DATE: ",%DT("B")="TODAY"
"RTN","IBNCPBB",140,0)
D ^%DT K %DT
"RTN","IBNCPBB",141,0)
I Y'>0 S IBEXIT=1 Q
"RTN","IBNCPBB",142,0)
S IBBDT=+Y
"RTN","IBNCPBB",143,0)
S %DT="AEX"
"RTN","IBNCPBB",144,0)
S %DT("A")="GO TO DATE: ",%DT("B")="TODAY" ;$$DAT2^IBOUTL(IBBDT)
"RTN","IBNCPBB",145,0)
D ^%DT K %DT
"RTN","IBNCPBB",146,0)
I Y'>0 S IBEXIT=1 Q
"RTN","IBNCPBB",147,0)
S IBEDT=+Y
"RTN","IBNCPBB",148,0)
Q
"RTN","IBNCPBB",149,0)
;
"RTN","IBNCPBB",150,0)
SELECT ;Select from patient's list
"RTN","IBNCPBB",151,0)
; (IBPAT,IBBDT,IBEDT,IBMOD3)
"RTN","IBNCPBB",152,0)
N IBD,IBRX,IBZ,IBDATA,IBCNT,Y,PDFN,LIST,LIST2,NODE,RXNUMEXT,LIST,IBDATE,CNT1,CNT2,RFNUM
"RTN","IBNCPBB",153,0)
S CNT1=0,CNT2=0,IBCNT=0
"RTN","IBNCPBB",154,0)
S LIST="IBRXSELARR"
"RTN","IBNCPBB",155,0)
S NODE=2
"RTN","IBNCPBB",156,0)
D RX^PSO52API(IBPAT,LIST,,,NODE,,)
"RTN","IBNCPBB",157,0)
S RXNUMEXT=0 F S RXNUMEXT=$O(^TMP($J,LIST,"B",RXNUMEXT)) Q:'RXNUMEXT D
"RTN","IBNCPBB",158,0)
. S IBRX=0 F S IBRX=$O(^TMP($J,LIST,"B",RXNUMEXT,IBRX)) Q:'IBRX D
"RTN","IBNCPBB",159,0)
.. S IBDATE=$P(^TMP($J,LIST,IBPAT,IBRX,31),"^",1)
"RTN","IBNCPBB",160,0)
.. I (IBDATE>IBBDT)&(IBDATE<IBEDT) D
"RTN","IBNCPBB",161,0)
... S IBZ=$$RXZERO^IBRXUTL(IBPAT,IBRX) Q:IBZ=""
"RTN","IBNCPBB",162,0)
... I $P(IBZ,U,2)'=IBPAT Q
"RTN","IBNCPBB",163,0)
... I '$$FILE^IBRXUTL(IBRX,31) Q ; not released
"RTN","IBNCPBB",164,0)
... S IBDATA=$$RXDATA(IBRX,0)
"RTN","IBNCPBB",165,0)
... I ('$P(IBDATA,U,6))!(IBMOD3="A") S IBCNT=IBCNT+1,@IBREF@(IBCNT)=IBDATA
"RTN","IBNCPBB",166,0)
... S LIST2="IBCPBBRF"
"RTN","IBNCPBB",167,0)
... S NODE="R"
"RTN","IBNCPBB",168,0)
... D RX^PSO52API(IBPAT,LIST2,IBRX,,NODE,,)
"RTN","IBNCPBB",169,0)
... S RFNUM=0 F S RFNUM=$O(^TMP($J,LIST2,IBPAT,IBRX,"RF",RFNUM)) Q:RFNUM'>0 D:$$SUBFILE^IBRXUTL(IBRX,RFNUM,52,17)
"RTN","IBNCPBB",170,0)
.... S IBDATA=$$RXDATA(IBRX,RFNUM)
"RTN","IBNCPBB",171,0)
.... I $P(IBDATA,U,6),IBMOD3'="A" Q ; unbilled only
"RTN","IBNCPBB",172,0)
.... S IBCNT=IBCNT+1,@IBREF@(IBCNT)=IBDATA
"RTN","IBNCPBB",173,0)
... K ^TMP($J,LIST2)
"RTN","IBNCPBB",174,0)
K ^TMP($J,LIST)
"RTN","IBNCPBB",175,0)
D MKCHOICE
"RTN","IBNCPBB",176,0)
Q
"RTN","IBNCPBB",177,0)
SELECT2 ;Select from Rx list
"RTN","IBNCPBB",178,0)
; (IBRX)
"RTN","IBNCPBB",179,0)
N IBCNT,Y,PDFN,RIFN,LST
"RTN","IBNCPBB",180,0)
S RIFN=0
"RTN","IBNCPBB",181,0)
W ! S IBPAUSE=1
"RTN","IBNCPBB",182,0)
S PDFN=$$FILE^IBRXUTL(IBRX,2)
"RTN","IBNCPBB",183,0)
S LST="SEL2LST"
"RTN","IBNCPBB",184,0)
I $$RXZERO^IBRXUTL(PDFN,IBRX)="" W !,"The Rx does not exist. Please try again." S IBEXIT=1 Q
"RTN","IBNCPBB",185,0)
I $$FILE^IBRXUTL(IBRX,31)="" W !,"The Rx has not been released. Please try again." S IBEXIT=1 Q
"RTN","IBNCPBB",186,0)
S IBCNT=1,@IBREF@(IBCNT)=$$RXDATA(IBRX,0)
"RTN","IBNCPBB",187,0)
D RX^PSO52API(PDFN,LST,IBRX,,"R",,)
"RTN","IBNCPBB",188,0)
S RIFN=0 F S RIFN=$O(^TMP($J,LST,PDFN,IBRX,"RF",RIFN)) Q:RIFN'>0 D:$$SUBFILE^IBRXUTL(IBRX,RIFN,52,17)
"RTN","IBNCPBB",189,0)
.S IBCNT=IBCNT+1,@IBREF@(IBCNT)=$$RXDATA(IBRX,RIFN)
"RTN","IBNCPBB",190,0)
K ^TMP($J,LST)
"RTN","IBNCPBB",191,0)
D MKCHOICE
"RTN","IBNCPBB",192,0)
Q
"RTN","IBNCPBB",193,0)
;
"RTN","IBNCPBB",194,0)
MKCHOICE ;
"RTN","IBNCPBB",195,0)
N Y
"RTN","IBNCPBB",196,0)
W !
"RTN","IBNCPBB",197,0)
S Y=0 F S Y=$O(@IBREF@(Y)) Q:'Y D DISP(Y)
"RTN","IBNCPBB",198,0)
;
"RTN","IBNCPBB",199,0)
I $O(@IBREF@(0))="" S IBEXIT=1 W !!," No Rxs meet the entered criteria. Please try again." Q
"RTN","IBNCPBB",200,0)
I $O(@IBREF@(""),-1)=1 S IBSEL(1)="" Q ; one item only
"RTN","IBNCPBB",201,0)
F W !!,"Enter Line Item(s) to submit to ECME or (A)LL :" R IBSEL:DTIME S:'$T IBEXIT=1 Q:IBEXIT Q:IBSEL'["?" D
"RTN","IBNCPBB",202,0)
. W !?10,"Enter number(s) or item range(s) separated by comma."
"RTN","IBNCPBB",203,0)
. W !?10,"Example: 1,3,7-11"
"RTN","IBNCPBB",204,0)
Q:IBEXIT
"RTN","IBNCPBB",205,0)
I IBSEL'="",$TR(IBSEL,"al","AL")=$E("ALL",1,$L(IBSEL)),$L(IBSEL)<3 W $E("ALL",$L(IBSEL)+1,3) S IBSEL="ALL"
"RTN","IBNCPBB",206,0)
I IBSEL="" S IBEXIT=1 W " Nothing selected" Q
"RTN","IBNCPBB",207,0)
I IBSEL="^" S IBEXIT=1 W " Cancelled" Q
"RTN","IBNCPBB",208,0)
;Collect the required into the IBSEL(i) local array
"RTN","IBNCPBB",209,0)
D PARSE(.IBSEL)
"RTN","IBNCPBB",210,0)
I $O(IBSEL(0))="" S IBEXIT=1 W !!,"No item(s) match the selection." Q
"RTN","IBNCPBB",211,0)
Q
"RTN","IBNCPBB",212,0)
;
"RTN","IBNCPBB",213,0)
CONFIRM ;
"RTN","IBNCPBB",214,0)
N DIR,Y
"RTN","IBNCPBB",215,0)
W !
"RTN","IBNCPBB",216,0)
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Submit the selected RX(s) to ECME for electronic billing"
"RTN","IBNCPBB",217,0)
D ^DIR I Y'=1 S IBEXIT=1
"RTN","IBNCPBB",218,0)
Q
"RTN","IBNCPBB",219,0)
;
"RTN","IBNCPBB",220,0)
CONFRX(IBRX) ;
"RTN","IBNCPBB",221,0)
N DIR,Y
"RTN","IBNCPBB",222,0)
W !
"RTN","IBNCPBB",223,0)
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Submit the Rx# "_IBRX_" to ECME for electronic billing"
"RTN","IBNCPBB",224,0)
D ^DIR I Y'=1 S IBEXIT=1
"RTN","IBNCPBB",225,0)
Q
"RTN","IBNCPBB",226,0)
;
"RTN","IBNCPBB",227,0)
STAT(X) ;
"RTN","IBNCPBB",228,0)
I +X<6 Q $P(X,"^",2)
"RTN","IBNCPBB",229,0)
Q "Unknown Status"
"RTN","IBNCPBB",230,0)
;
"RTN","IBNCPBB",231,0)
BILL(IBRXN,IBDT) ;Bill IEN (if any) or null
"RTN","IBNCPBB",232,0)
N RES,X,IBZ
"RTN","IBNCPBB",233,0)
S IBDT=$P(IBDT,".")
"RTN","IBNCPBB",234,0)
S RES=""
"RTN","IBNCPBB",235,0)
S X="" F S X=$O(^IBA(362.4,"B",IBRXN,X),-1) Q:X="" D:X Q:RES
"RTN","IBNCPBB",236,0)
. S IBZ=$G(^IBA(362.4,X,0))
"RTN","IBNCPBB",237,0)
. I $P($P(IBZ,U,3),".")=IBDT,$P(IBZ,U,2) S RES=+$P(IBZ,U,2)
"RTN","IBNCPBB",238,0)
Q RES
"RTN","IBNCPBB",239,0)
;
"RTN","IBNCPBB",240,0)
;
"RTN","IBNCPBB",241,0)
RXDATA(IBRX,IBFIL) ;
"RTN","IBNCPBB",242,0)
;RxIEN^Rx#^Fill#^RelDate^DrugIEN^BillIEN
"RTN","IBNCPBB",243,0)
N IBRXN,IBDT,IBDRUG,IBBIL,DATRET
"RTN","IBNCPBB",244,0)
S IBRXN=$$FILE^IBRXUTL(IBRX,.01)
"RTN","IBNCPBB",245,0)
I IBFIL=0 S IBDT=$$FILE^IBRXUTL(IBRX,22)
"RTN","IBNCPBB",246,0)
E S IBDT=$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,.01)
"RTN","IBNCPBB",247,0)
S IBDT=$P(IBDT,".")
"RTN","IBNCPBB",248,0)
S IBDRUG=$$FILE^IBRXUTL(IBRX,6)
"RTN","IBNCPBB",249,0)
S IBBIL=$$BILL(IBRXN,IBDT)
"RTN","IBNCPBB",250,0)
S DATRET=IBRX_"^"_IBRXN_"^"_IBFIL_"^"_IBDT_"^"_IBDRUG_"^"_IBBIL
"RTN","IBNCPBB",251,0)
Q DATRET
"RTN","IBNCPBB",252,0)
;
"RTN","IBNCPBB",253,0)
DISP(IBITEM) ;
"RTN","IBNCPBB",254,0)
N IBD,IBBILN,IBDRUG,IBBIL
"RTN","IBNCPBB",255,0)
S IBD=$G(@IBREF@(IBITEM)) Q:IBD=""
"RTN","IBNCPBB",256,0)
W !,IBITEM," ",?4,$P(IBD,U,2)," ",?15,$P(IBD,U,3)," ",?20,$$DAT2^IBOUTL($P(IBD,U,4))," "
"RTN","IBNCPBB",257,0)
W ?32,$E($$DRUG^IBRXUTL1(+$P(IBD,U,5)),1,30)
"RTN","IBNCPBB",258,0)
S IBBIL=$P(IBD,U,6)
"RTN","IBNCPBB",259,0)
I IBBIL W ?64,$P($G(^DGCR(399,+IBBIL,0)),U) I $P($G(^DGCR(399,IBBIL,"S")),U,16) W "(canc)"
"RTN","IBNCPBB",260,0)
Q
"RTN","IBNCPBB",261,0)
;
"RTN","IBNCPBB",262,0)
PARSE(X) ;
"RTN","IBNCPBB",263,0)
N I,J,N
"RTN","IBNCPBB",264,0)
S X=$TR(X," ")
"RTN","IBNCPBB",265,0)
S X=$TR(X,";",",")
"RTN","IBNCPBB",266,0)
I $TR(IBSEL,"al","AL")="ALL" D Q
"RTN","IBNCPBB",267,0)
. F I=1:1 Q:'$D(@IBREF@(I)) S IBSEL(I)=""
"RTN","IBNCPBB",268,0)
F I=1:1:$L(X,",") S N=$P(X,",",I) D:N'=""
"RTN","IBNCPBB",269,0)
. I N'["-" D:N Q
"RTN","IBNCPBB",270,0)
. . I $D(@IBREF@(N)) S X(N)=""
"RTN","IBNCPBB",271,0)
. ; Processing range
"RTN","IBNCPBB",272,0)
. N N1,N2
"RTN","IBNCPBB",273,0)
. S N1=+$P(N,"-",1),N2=+$P(N,"-",2)
"RTN","IBNCPBB",274,0)
. F J=N1:$S(N2<N1:-1,1:1):N2 I $D(@IBREF@(J)) S X(J)=""
"RTN","IBNCPBB",275,0)
Q
"RTN","IBNCPBB",276,0)
;
"RTN","IBNCPBB",277,0)
PAUSE(MESSAGE) ;
"RTN","IBNCPBB",278,0)
D EN^DDIOL("","","!")
"RTN","IBNCPBB",279,0)
I $G(MESSAGE)'="" D EN^DDIOL(MESSAGE) D EN^DDIOL(". ","","?0")
"RTN","IBNCPBB",280,0)
D EN^DDIOL("Press RETURN to continue: ")
"RTN","IBNCPBB",281,0)
R %:DTIME
"RTN","IBNCPBB",282,0)
Q
"RTN","IBNCPBB",283,0)
;
"RTN","IBNCPBB",284,0)
SC(IEN) ;Service connected
"RTN","IBNCPBB",285,0)
N IBT
"RTN","IBNCPBB",286,0)
I 'IEN Q 0
"RTN","IBNCPBB",287,0)
S IBT=$P($G(^IBE(356.8,IEN,0)),U)
"RTN","IBNCPBB",288,0)
I IBT="NEEDS SC DETERMINATION" Q 1
"RTN","IBNCPBB",289,0)
I IBT="OTHER" Q 1
"RTN","IBNCPBB",290,0)
Q 0
"RTN","IBNCPBB",291,0)
;
"RTN","IBNCPBB",292,0)
;
"RTN","IBNCPBB",293,0)
DLYRC(DFLT) ; function, ask for NCPDP field 357-NV Delay Reason Code
"RTN","IBNCPBB",294,0)
; DFLT = optional default value (integer from 1-14)
"RTN","IBNCPBB",295,0)
; returns code or "^" on time-out, etc.
"RTN","IBNCPBB",296,0)
N IBDELAY,C,DIC,DIR,DIRUT,DIROUT,DUOUT,DTOUT,X,Y
"RTN","IBNCPBB",297,0)
S IBDELAY=""
"RTN","IBNCPBB",298,0)
I $G(DFLT)?1.2N,DFLT>0,DFLT<15 S DIR("B")=DFLT
"RTN","IBNCPBB",299,0)
S DIR(0)="PO^9002313.29:EMZ" D ^DIR K DIR ; IA# TBD
"RTN","IBNCPBB",300,0)
S IBDELAY=$S($D(DTOUT)!$D(DUOUT)!$D(DIROUT)!$D(DIRUT):"^",1:Y)
"RTN","IBNCPBB",301,0)
S IBDELAY=+$P((IBDELAY),"^",1)
"RTN","IBNCPBB",302,0)
Q IBDELAY
"RTN","IBNCPBB",303,0)
;
"RTN","IBNCPBB",304,0)
;IBNCPBB
"RTN","IBNCPBB1")
0^5^B5603763
"RTN","IBNCPBB1",1,0)
IBNCPBB1 ;ALB/BDB - CONTINUATION OF ECME BACKBILLING ;24-JUN-2003
"RTN","IBNCPBB1",2,0)
;;2.0;INTEGRATED BILLING;**384,550,624**;21-MAR-94;Build 8
"RTN","IBNCPBB1",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBNCPBB1",4,0)
;
"RTN","IBNCPBB1",5,0)
Q
"RTN","IBNCPBB1",6,0)
;
"RTN","IBNCPBB1",7,0)
PROCESS ;
"RTN","IBNCPBB1",8,0)
N RES,IBY,IBD,IBRX,IBFIL,IBERR,IBBIL,IBPAT,IBDRUG,IBINS,IBDT,IBQ
"RTN","IBNCPBB1",9,0)
S IBERR=0
"RTN","IBNCPBB1",10,0)
S IBY=0 F S IBY=$O(IBSEL(IBY)) Q:'IBY D
"RTN","IBNCPBB1",11,0)
. S IBD=$G(@IBREF@(IBY)) Q:IBD=""
"RTN","IBNCPBB1",12,0)
. S IBRX=$P(IBD,U),IBFIL=+$P(IBD,U,3),IBBIL=$P(IBD,U,6)
"RTN","IBNCPBB1",13,0)
. W !,"Submitting Rx# ",$P(IBD,U,2) W:IBFIL "Refill# ",IBFIL W:'IBFIL " (original fill)" W " ..."
"RTN","IBNCPBB1",14,0)
. I IBBIL,'$P($G(^DGCR(399,IBBIL,"S")),U,16) D S IBERR=IBERR+1 Q
"RTN","IBNCPBB1",15,0)
.. W !," *** Rx# ",$P(IBD,U,2)," was previously billed."
"RTN","IBNCPBB1",16,0)
.. W !," Please cancel the Bill No ",$P($G(^DGCR(399,IBBIL,0)),U)," before submitting the claim"
"RTN","IBNCPBB1",17,0)
. ; Sensitive Diagnosis Drug/ROI Check
"RTN","IBNCPBB1",18,0)
. S IBDRUG=$P(IBD,U,5)
"RTN","IBNCPBB1",19,0)
. I $$SENS^IBNCPDR(IBDRUG) D Q:'IBQ
"RTN","IBNCPBB1",20,0)
.. S IBPAT=$$FILE^IBRXUTL(IBRX,2)
"RTN","IBNCPBB1",21,0)
.. S IBDT=$P(IBD,U,4)
"RTN","IBNCPBB1",22,0)
.. I '$$INSUR^IBBAPI(IBPAT,IBDT,"P",.IBANY,1) S IBQ=1 Q
"RTN","IBNCPBB1",23,0)
.. S IBINS=+$G(IBANY("IBBAPI","INSUR",1,1))
"RTN","IBNCPBB1",24,0)
.. ; Check to see if the Date of Service is on or after the Mission Act Implementation
"RTN","IBNCPBB1",25,0)
.. ; Date if so don't check for ROI on file ROI
"RTN","IBNCPBB1",26,0)
.. I $$MACHK^IBNCPDR4(IBDT) S IBQ=1
"RTN","IBNCPBB1",27,0)
.. ; If there's an ROI on file (IBQ=1) then D ROICLN^IBNCPDR4
"RTN","IBNCPBB1",28,0)
.. S IBQ=$$ROICHK^IBNCPDR4(IBPAT,IBDRUG,IBINS,IBDT)
"RTN","IBNCPBB1",29,0)
.. I IBQ=1 D ROICLN^IBNCPDR4("",IBRX,IBFIL)
"RTN","IBNCPBB1",30,0)
.. I 'IBQ S IBERR=IBERR+1
"RTN","IBNCPBB1",31,0)
. S RES=$$SUBMIT^IBNCPDPU(IBRX,IBFIL) W " ",$S(+RES=0:"Sent through ECME",1:"Not sent")
"RTN","IBNCPBB1",32,0)
. I +RES'=0 W !?5,"*** ECME returned status: ",$$STAT^IBNCPBB(RES) S IBERR=IBERR+1
"RTN","IBNCPBB1",33,0)
I 'IBERR W !!,"The selected Rx(s) have been submitted to ECME",!,"for electronic billing"
"RTN","IBNCPBB1",34,0)
Q
"RTN","IBNCPBB1",35,0)
;
"RTN","IBNCPBB1",36,0)
;IBNCPBB1
"RTN","IBNCPDP1")
0^2^B184856569
"RTN","IBNCPDP1",1,0)
IBNCPDP1 ;OAK/ELZ - IB BILLING DETERMINATION PROCESSING FOR NEW RX REQUESTS ;5/22/08
"RTN","IBNCPDP1",2,0)
;;2.0;INTEGRATED BILLING;**223,276,339,363,383,405,384,411,434,437,435,455,452,473,494,534,550,617,624**;21-MAR-94;Build 8
"RTN","IBNCPDP1",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBNCPDP1",4,0)
;
"RTN","IBNCPDP1",5,0)
; Reference to CL^SDCO21 supported by IA# 406
"RTN","IBNCPDP1",6,0)
; Reference to IN5^VADPT supported by IA# 10061
"RTN","IBNCPDP1",7,0)
; Reference to $$MWC^PSOBPSU2 supported by IA# 4970
"RTN","IBNCPDP1",8,0)
;
"RTN","IBNCPDP1",9,0)
RX(DFN,IBD) ; pharmacy package call, passing in IBD by ref
"RTN","IBNCPDP1",10,0)
; this is called by PSO for all prescriptions issued, return is
"RTN","IBNCPDP1",11,0)
; a response to bill ECME or not with array for billing data elements
"RTN","IBNCPDP1",12,0)
;
"RTN","IBNCPDP1",13,0)
;warning: back-billing flag:
"RTN","IBNCPDP1",14,0)
;if passed IBSCRES(IBRXN,IBFIL)=1
"RTN","IBNCPDP1",15,0)
; - then the SC Determination is just done by the IB clerk (billable)
"RTN","IBNCPDP1",16,0)
; - set by routine IBNCPBB
"RTN","IBNCPDP1",17,0)
;
"RTN","IBNCPDP1",18,0)
; IBD("PLAN") - is specified only if RX API is called for billing
"RTN","IBNCPDP1",19,0)
; determination for secondary claims or if the user is resubmitting
"RTN","IBNCPDP1",20,0)
; a claim from the PSO Reject Information Screen.
"RTN","IBNCPDP1",21,0)
;
"RTN","IBNCPDP1",22,0)
;clean up the list of non-answered SC/Env.indicators questions and INS
"RTN","IBNCPDP1",23,0)
K IBD("SC/EI NO ANSW"),IBD("INS")
"RTN","IBNCPDP1",24,0)
;
"RTN","IBNCPDP1",25,0)
N IBTRKR,IBARR,IBADT,IBRXN,IBFIL,IBTRKRN,IBRMARK,IBANY,IBX,IBT,IBINS,IBSAVE,IBPRDATA,IBDISPFEE,IBADMINFEE
"RTN","IBNCPDP1",26,0)
N IBFEE,IBBI,IBIT,IBPRICE,IBRS,IBRT,IBTRN,IBCHG,IBRES,IBNEEDS,IBELIG,IBDEA,IBPTYP,IBACDUTY,IBINSXRES,IBROIMA
"RTN","IBNCPDP1",27,0)
;
"RTN","IBNCPDP1",28,0)
; eligibility verification request flag - esg 9/9/10 IB*2*435
"RTN","IBNCPDP1",29,0)
S IBELIG=($G(IBD("RX ACTION"))="ELIG")
"RTN","IBNCPDP1",30,0)
;
"RTN","IBNCPDP1",31,0)
I '$G(DFN) S IBRES="0^No DFN" G RXQ
"RTN","IBNCPDP1",32,0)
;
"RTN","IBNCPDP1",33,0)
S IBRES="0^Error"
"RTN","IBNCPDP1",34,0)
S IBADT=+$G(IBD("DOS"),DT) ; date of service (default to today)
"RTN","IBNCPDP1",35,0)
;
"RTN","IBNCPDP1",36,0)
; -- gather all active pharmacy insurance policies for patient on date of service
"RTN","IBNCPDP1",37,0)
D RXINS^IBNCPDPU(DFN,IBADT,.IBINS)
"RTN","IBNCPDP1",38,0)
;
"RTN","IBNCPDP1",39,0)
; -- determine rate type
"RTN","IBNCPDP1",40,0)
S IBRT=$$RT^IBNCPDPU(DFN,IBADT,.IBINS,.IBPTYP)
"RTN","IBNCPDP1",41,0)
;
"RTN","IBNCPDP1",42,0)
; If the rate type was selected by the user for manual primary or secondary claims processing, then update IBRT
"RTN","IBNCPDP1",43,0)
I $G(IBD("RTYPE")),$G(IBD("PLAN")) D
"RTN","IBNCPDP1",44,0)
. S $P(IBRT,U,1)=+IBD("RTYPE") ; overwrite the rate type ien [1]
"RTN","IBNCPDP1",45,0)
. S $P(IBRT,U,2)=$$COSTTYP^IBNCPUT3(+IBD("RTYPE"),IBADT) ; overwrite the basis of cost determination [2]
"RTN","IBNCPDP1",46,0)
. I $P(IBRT,U,3)="" S $P(IBRT,U,3)=IBPTYP ; overwrite eligibility if null [3]
"RTN","IBNCPDP1",47,0)
. Q
"RTN","IBNCPDP1",48,0)
;
"RTN","IBNCPDP1",49,0)
; -- Process an eligibility verification request
"RTN","IBNCPDP1",50,0)
I IBELIG D G RXQ
"RTN","IBNCPDP1",51,0)
. S IBRES=1
"RTN","IBNCPDP1",52,0)
. D SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES)
"RTN","IBNCPDP1",53,0)
. Q
"RTN","IBNCPDP1",54,0)
;
"RTN","IBNCPDP1",55,0)
; additional data integrity checks
"RTN","IBNCPDP1",56,0)
S IBRXN=+$G(IBD("IEN")) I 'IBRXN S IBRES="0^No Rx IEN" G RXQ
"RTN","IBNCPDP1",57,0)
S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G RXQ
"RTN","IBNCPDP1",58,0)
S IBD("QTY")=+$G(IBD("QTY")) I 'IBD("QTY") S IBRES="0^No Quantity" G RXQ
"RTN","IBNCPDP1",59,0)
;
"RTN","IBNCPDP1",60,0)
; -- Gather claims tracking information if it exists
"RTN","IBNCPDP1",61,0)
S IBTRKR=$G(^IBE(350.9,1,6))
"RTN","IBNCPDP1",62,0)
; date can't be before parameters
"RTN","IBNCPDP1",63,0)
S $P(IBTRKR,U)=$S('$P(IBTRKR,U,4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
"RTN","IBNCPDP1",64,0)
; already in claims tracking
"RTN","IBNCPDP1",65,0)
S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
"RTN","IBNCPDP1",66,0)
;
"RTN","IBNCPDP1",67,0)
; Gather and store insurance information in the IBD("INS") insurance array
"RTN","IBNCPDP1",68,0)
D SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES)
"RTN","IBNCPDP1",69,0)
I $G(IBD("NO ECME INSURANCE")) S IBINSXRES=$G(IBRES) ; save IBRES when there are insurance errors
"RTN","IBNCPDP1",70,0)
;
"RTN","IBNCPDP1",71,0)
;for secondary billing - skip claim tracking functionality
"RTN","IBNCPDP1",72,0)
G:$G(IBD("RXCOB"))>1 GETINS
"RTN","IBNCPDP1",73,0)
;
"RTN","IBNCPDP1",74,0)
; -- claims tracking info
"RTN","IBNCPDP1",75,0)
I IBTRKRN,$$PAPERBIL^IBNCPNB(IBTRKRN) S IBRES="0^Existing IB Bill in CT",IBD("NO ECME INSURANCE")=1 G RXQ
"RTN","IBNCPDP1",76,0)
;
"RTN","IBNCPDP1",77,0)
; -- no pharmacy coverage, update ct if applicable, quit
"RTN","IBNCPDP1",78,0)
I '$$PTCOV^IBCNSU3(DFN,IBADT,"PHARMACY",.IBANY) S IBRMARK=$S($G(IBANY):"SERVICE NOT COVERED",1:"NOT INSURED") D:$P(IBTRKR,U,4)=2 CT S IBRES="0^"_IBRMARK,IBD("NO ECME INSURANCE")=1 G RXQ
"RTN","IBNCPDP1",79,0)
;
"RTN","IBNCPDP1",80,0)
; Environmental Indicators Validation
"RTN","IBNCPDP1",81,0)
; Find out if the patient is Active Duty - IB*2*534
"RTN","IBNCPDP1",82,0)
S IBACDUTY=$P(IBRT,U,3)="T"&$$ACDUTY^IBNCPDPU(DFN)
"RTN","IBNCPDP1",83,0)
; Retrieve indicators from file #52 and overwrite the indicators in IBD array
"RTN","IBNCPDP1",84,0)
D GETINDIC^IBNCPUT2(+IBD("IEN"),.IBD)
"RTN","IBNCPDP1",85,0)
; Process patient exemptions if any and if not already resolved
"RTN","IBNCPDP1",86,0)
S IBNEEDS=0 ;flag will be set to 1 if at least one of the questions wasn't answered
"RTN","IBNCPDP1",87,0)
I $G(IBD("SC/EI OVR"))'=1,'IBACDUTY D
"RTN","IBNCPDP1",88,0)
. D CL^SDCO21(DFN,IBADT,"",.IBARR)
"RTN","IBNCPDP1",89,0)
. I $D(IBARR)>9 F IBX=2:1 S IBT=$P($T(EXEMPT+IBX),";;",2) Q:IBT="" D:$D(IBARR(+IBT))
"RTN","IBNCPDP1",90,0)
. . I $G(IBD($P(IBT,U,2)))=0 Q
"RTN","IBNCPDP1",91,0)
. . I $G(IBD($P(IBT,U,2))) S IBRMARK=$P(IBT,U,3) Q
"RTN","IBNCPDP1",92,0)
. . I '$G(IBSCRES(IBRXN,IBFIL)) S IBNEEDS=1 D
"RTN","IBNCPDP1",93,0)
. . . S IBD("SC/EI NO ANSW")=$S($G(IBD("SC/EI NO ANSW"))="":$P(IBT,U,2),1:$G(IBD("SC/EI NO ANSW"))_","_$P(IBT,U,2))
"RTN","IBNCPDP1",94,0)
I '$D(IBRMARK),IBNEEDS=1 S IBRMARK="NEEDS SC DETERMINATION"
"RTN","IBNCPDP1",95,0)
I $D(IBRMARK) D CT S IBRES="0^"_IBRMARK G RXQ
"RTN","IBNCPDP1",96,0)
;
"RTN","IBNCPDP1",97,0)
; -- check for drug billable
"RTN","IBNCPDP1",98,0)
I '$$BILLABLE^IBNCPDP($G(IBD("DRUG")),$P(IBRT,U,3),.IBRMARK,.IBD) S IBRES="0^"_IBRMARK D CT G RXQ
"RTN","IBNCPDP1",99,0)
;
"RTN","IBNCPDP1",100,0)
; -- check for sensitive diagnosis drug and ROI on file
"RTN","IBNCPDP1",101,0)
;$$SENS^IBNCPDR returns 1 if the drug is a sensitive diagnosis drug
"RTN","IBNCPDP1",102,0)
I $$SENS^IBNCPDR($G(IBD("DRUG")),.IBD),$D(IBD("INS",1,3)) D
"RTN","IBNCPDP1",103,0)
. ; -- if the Date of Service is on or after the Mission Act Implementation Date do
"RTN","IBNCPDP1",104,0)
. ; not perform ROI checks
"RTN","IBNCPDP1",105,0)
. S IBROIMA=$$MACHK^IBNCPDR4(IBADT)
"RTN","IBNCPDP1",106,0)
. I 'IBROIMA,'$$ROI^IBNCPDR4(DFN,$G(IBD("DRUG")),+$P($G(IBD("INS",1,3)),U,5),IBADT) D Q
"RTN","IBNCPDP1",107,0)
.. ;
"RTN","IBNCPDP1",108,0)
.. ; no active ROI found for patient/drug/insurance/DOS
"RTN","IBNCPDP1",109,0)
.. S IBRMARK="ROI NOT OBTAINED"
"RTN","IBNCPDP1",110,0)
.. S IBRES="0^NO ACTIVE/VALID ROI FOR DRUG OR INSURANCE" ; PSO routine PSOREJU3 contains this text
"RTN","IBNCPDP1",111,0)
.. Q
"RTN","IBNCPDP1",112,0)
. ;
"RTN","IBNCPDP1",113,0)
. ; active ROI found, clear out RNB from Claims Tracking and variable IBRMARK
"RTN","IBNCPDP1",114,0)
. D ROICLN^IBNCPDR4(IBTRKRN,IBRXN,IBFIL)
"RTN","IBNCPDP1",115,0)
. I $G(IBRMARK)["ROI" K IBRMARK
"RTN","IBNCPDP1",116,0)
. Q
"RTN","IBNCPDP1",117,0)
I $D(IBRMARK) D CT G RXQ
"RTN","IBNCPDP1",118,0)
;
"RTN","IBNCPDP1",119,0)
; Clean-up the NEEDS SC DETERMINATION record if resolved
"RTN","IBNCPDP1",120,0)
; And check if it is non-billable in CT
"RTN","IBNCPDP1",121,0)
I IBTRKRN D
"RTN","IBNCPDP1",122,0)
. N IBNBR,IBNBRT
"RTN","IBNCPDP1",123,0)
. S IBNBR=$P($G(^IBT(356,+IBTRKRN,0)),U,19) Q:'IBNBR
"RTN","IBNCPDP1",124,0)
. S IBNBRT=$P($G(^IBE(356.8,IBNBR,0)),U) Q:IBNBRT=""
"RTN","IBNCPDP1",125,0)
. ;
"RTN","IBNCPDP1",126,0)
. ; if refill was deleted (not RX) and now the refill is re-entered
"RTN","IBNCPDP1",127,0)
. ;use $$RXSTATUS^IBNCPRR instead of $G(^PSRX(IBRXN,"STA"))
"RTN","IBNCPDP1",128,0)
. I IBNBRT="PRESCRIPTION DELETED",$$RXSTATUS^IBNCPRR(DFN,IBRXN)'=13 D Q
"RTN","IBNCPDP1",129,0)
. . N DIE,DA,DR
"RTN","IBNCPDP1",130,0)
. . ; clean up REASON NOT BILLABLE and ADDITIONAL COMMENT
"RTN","IBNCPDP1",131,0)
. . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@;1.08////@" D ^DIE
"RTN","IBNCPDP1",132,0)
. ;
"RTN","IBNCPDP1",133,0)
. ; Clean up NBR if released
"RTN","IBNCPDP1",134,0)
. I IBNBRT="PRESCRIPTION NOT RELEASED" D:$G(IBD("RELEASE DATE")) Q
"RTN","IBNCPDP1",135,0)
. . N DIE,DA,DR
"RTN","IBNCPDP1",136,0)
. . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE
"RTN","IBNCPDP1",137,0)
. ;
"RTN","IBNCPDP1",138,0)
. ; Clean up 'Needs SC determ'
"RTN","IBNCPDP1",139,0)
. I IBNBRT="NEEDS SC DETERMINATION" D Q
"RTN","IBNCPDP1",140,0)
. . N DIE,DA,DR
"RTN","IBNCPDP1",141,0)
. . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE
"RTN","IBNCPDP1",142,0)
. ;
"RTN","IBNCPDP1",143,0)
. ; Clean up 'DRUG NOT BILLABLE' since we made it through the $$BILLABLE function above - IB*2*550
"RTN","IBNCPDP1",144,0)
. I IBNBRT="DRUG NOT BILLABLE" D Q
"RTN","IBNCPDP1",145,0)
.. N DIE,DA,DR
"RTN","IBNCPDP1",146,0)
.. S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@;1.08////@" D ^DIE
"RTN","IBNCPDP1",147,0)
.. Q
"RTN","IBNCPDP1",148,0)
. ;
"RTN","IBNCPDP1",149,0)
. S IBRMARK=IBNBRT
"RTN","IBNCPDP1",150,0)
I $D(IBRMARK) S IBRES="0^Non-Billable in CT: "_IBRMARK G RXQ
"RTN","IBNCPDP1",151,0)
;
"RTN","IBNCPDP1",152,0)
GETINS ; -- examine the insurance data for a patient
"RTN","IBNCPDP1",153,0)
;
"RTN","IBNCPDP1",154,0)
; if insurance errors were detected earlier, then restore IBRES and get out
"RTN","IBNCPDP1",155,0)
I $G(IBD("NO ECME INSURANCE")) S IBRES=$G(IBINSXRES) G RXQ
"RTN","IBNCPDP1",156,0)
;
"RTN","IBNCPDP1",157,0)
RATEPRIC ; determine rates/prices to use
"RTN","IBNCPDP1",158,0)
;
"RTN","IBNCPDP1",159,0)
I 'IBRT D CT S IBRES="0^Cannot determine Rate type" G RXQ
"RTN","IBNCPDP1",160,0)
S IBBI=$$EVNTITM^IBCRU3(+IBRT,3,"PRESCRIPTION FILL",IBADT,.IBRS)
"RTN","IBNCPDP1",161,0)
I 'IBBI,$P(IBBI,";")'="VA COST" D CT S IBRES="0^Cannot find Billable Item" G RXQ
"RTN","IBNCPDP1",162,0)
;
"RTN","IBNCPDP1",163,0)
; Check for missing NDC
"RTN","IBNCPDP1",164,0)
I $G(IBD("NDC"))="" D CT S IBRES="0^Missing NDC" G RXQ
"RTN","IBNCPDP1",165,0)
;
"RTN","IBNCPDP1",166,0)
;1;BEDSECTION;1^
"RTN","IBNCPDP1",167,0)
;IBRS(1,18,5)=
"RTN","IBNCPDP1",168,0)
S IBRS=+$O(IBRS($P(IBBI,";"),0))
"RTN","IBNCPDP1",169,0)
S IBIT=$$ITPTR^IBCRU2($P(IBBI,";"),$S($P(IBRT,U,2)="A":$$NDC^IBNCPNB($G(IBD("NDC"))),1:"PRESCRIPTION"))
"RTN","IBNCPDP1",170,0)
I 'IBIT,$P(IBRT,U,2)'="C" D CT S IBRES="0^Cannot find Item Pointer" G RXQ
"RTN","IBNCPDP1",171,0)
;8
"RTN","IBNCPDP1",172,0)
S IBPRICE=+$$BICOST^IBCRCI(+IBRT,3,IBADT,"PRESCRIPTION FILL",+IBIT,,,$S($P(IBRT,U,2)="A":IBD("QTY"),1:1))
"RTN","IBNCPDP1",173,0)
;36^2991001
"RTN","IBNCPDP1",174,0)
;
"RTN","IBNCPDP1",175,0)
; return the true value of drug cost for 3rd party bill if it is zero
"RTN","IBNCPDP1",176,0)
I IBD("COST")=0,$P($G(^DGCR(399.3,+$P(IBRT,U,1),0)),U,5) S IBD("COST")=$$RXPCT(.IBD,.BWHERE)
"RTN","IBNCPDP1",177,0)
;
"RTN","IBNCPDP1",178,0)
; get fees if any, ignore return, don't care about price, just need fees
"RTN","IBNCPDP1",179,0)
S IBCHG=$$RATECHG^IBCRCC(+IBRS,$S($P(IBRT,U,2)'="C":1,1:IBD("QTY")*IBD("COST")),IBADT,.IBFEE)
"RTN","IBNCPDP1",180,0)
I $P(IBRT,U,2)="C" S IBPRICE=+IBCHG
"RTN","IBNCPDP1",181,0)
;
"RTN","IBNCPDP1",182,0)
S IBDISPFEE=+$P($G(IBFEE),U,1) ; dispensing fee
"RTN","IBNCPDP1",183,0)
S IBADMINFEE=+$P($G(IBFEE),U,2) ; administrative fee
"RTN","IBNCPDP1",184,0)
;
"RTN","IBNCPDP1",185,0)
I 'IBPRICE D CT S IBRES="0^Cannot find price for Item" G RXQ
"RTN","IBNCPDP1",186,0)
;
"RTN","IBNCPDP1",187,0)
; build pricing data string
"RTN","IBNCPDP1",188,0)
S IBPRDATA=""
"RTN","IBNCPDP1",189,0)
S $P(IBPRDATA,U,1)=IBDISPFEE ; dispensing fee
"RTN","IBNCPDP1",190,0)
S $P(IBPRDATA,U,2)=$S($P(IBRT,U,2)="A":"01",$P(IBRT,U,2)="C":"05",1:"07") ; basis of cost determination
"RTN","IBNCPDP1",191,0)
S $P(IBPRDATA,U,3)=$S($P(IBRT,U,2)="C":IBD("QTY")*IBD("COST")+IBDISPFEE,$P(IBRT,U,2)="A":IBPRICE-IBDISPFEE-IBADMINFEE,1:IBPRICE) ; basis of cost amount
"RTN","IBNCPDP1",192,0)
S $P(IBPRDATA,U,4)=IBPRICE ; gross amount due
"RTN","IBNCPDP1",193,0)
S $P(IBPRDATA,U,5)=IBADMINFEE ; administrative fee
"RTN","IBNCPDP1",194,0)
S $P(IBPRDATA,U,6)=IBD("QTY")*IBD("COST") ; ingredient cost
"RTN","IBNCPDP1",195,0)
S $P(IBPRDATA,U,7)=IBPRICE-IBADMINFEE ; usual & customary charge (U&C)
"RTN","IBNCPDP1",196,0)
;
"RTN","IBNCPDP1",197,0)
; store the pricing data string on each node 2 that may exist
"RTN","IBNCPDP1",198,0)
S IBX=0 F S IBX=$O(IBD("INS",IBX)) Q:'IBX S IBD("INS",IBX,2)=IBPRDATA
"RTN","IBNCPDP1",199,0)
;
"RTN","IBNCPDP1",200,0)
S IBRES=$S($D(IBRMARK):"0^"_IBRMARK,1:1)
"RTN","IBNCPDP1",201,0)
I IBRES,'$G(IBD("RELEASE DATE")) S IBRMARK="PRESCRIPTION NOT RELEASED"
"RTN","IBNCPDP1",202,0)
;
"RTN","IBNCPDP1",203,0)
D CT
"RTN","IBNCPDP1",204,0)
;
"RTN","IBNCPDP1",205,0)
RXQ ; final processing
"RTN","IBNCPDP1",206,0)
; set the 3rd piece of IBRES (default Vet)
"RTN","IBNCPDP1",207,0)
S $P(IBRES,U,3)=$S($L($P($G(IBRT),U,3)):$P(IBRT,U,3),1:"V")
"RTN","IBNCPDP1",208,0)
;
"RTN","IBNCPDP1",209,0)
; possibly add entries to files 366.14 and 366.15 (not for eligibility verification requests)
"RTN","IBNCPDP1",210,0)
I 'IBELIG D
"RTN","IBNCPDP1",211,0)
. I IBRES D START^IBNCPDP6(IBRXN_";"_IBFIL,$P(IBRES,U,3),+IBRT)
"RTN","IBNCPDP1",212,0)
. D LOG^IBNCPDP2("BILLABLE STATUS CHECK",IBRES)
"RTN","IBNCPDP1",213,0)
. Q
"RTN","IBNCPDP1",214,0)
;
"RTN","IBNCPDP1",215,0)
Q IBRES
"RTN","IBNCPDP1",216,0)
;
"RTN","IBNCPDP1",217,0)
;
"RTN","IBNCPDP1",218,0)
CT ; files in claims tracking
"RTN","IBNCPDP1",219,0)
Q:$G(IBD("RXCOB"))>1 ;Claim Tracking is updated only for the primary payer (payer sequence =1)
"RTN","IBNCPDP1",220,0)
;If null then the payer sequence = Primary is assumed
"RTN","IBNCPDP1",221,0)
I IBTRKR D CT^IBNCPDPU(DFN,IBRXN,IBFIL,IBADT,$G(IBRMARK))
"RTN","IBNCPDP1",222,0)
Q
"RTN","IBNCPDP1",223,0)
;
"RTN","IBNCPDP1",224,0)
SETINSUR(IBADT,IBRT,IBELIG,IBINS,IBD,IBRES) ; build insurance data array
"RTN","IBNCPDP1",225,0)
; Input variables:
"RTN","IBNCPDP1",226,0)
; IBADT - date of service/identify insurance as of this date
"RTN","IBNCPDP1",227,0)
; IBRT - rate type variable - [1] rate type ien, [2] type (A/C/T), [3] eligibility (V/T/C)
"RTN","IBNCPDP1",228,0)
; IBELIG - eligibility request flag (1/0)
"RTN","IBNCPDP1",229,0)
; IBINS - insurance array as returned by RXINS^IBNCPDPU
"RTN","IBNCPDP1",230,0)
; IBD - input/output - array entries passed in and certain array entries returned
"RTN","IBNCPDP1",231,0)
; Output variable:
"RTN","IBNCPDP1",232,0)
; IBRES - only returned if insurance errors
"RTN","IBNCPDP1",233,0)
;
"RTN","IBNCPDP1",234,0)
; Note: if more than one insurance with the same COB then the latest insurance occurrence overrides the first one(s)
"RTN","IBNCPDP1",235,0)
; Example:
"RTN","IBNCPDP1",236,0)
; IBINS("S",1,1)=""
"RTN","IBNCPDP1",237,0)
; IBINS("S",1,3)="" <<--- this will be primary
"RTN","IBNCPDP1",238,0)
;
"RTN","IBNCPDP1",239,0)
K IBD("INS"),IBD("NO ECME INSURANCE")
"RTN","IBNCPDP1",240,0)
;
"RTN","IBNCPDP1",241,0)
N IBCNT,IBERMSG,IBRXPOL,IBT,IBX
"RTN","IBNCPDP1",242,0)
; IBERMSG - error message array
"RTN","IBNCPDP1",243,0)
; IBRXPOL - array of Rx policies found
"RTN","IBNCPDP1",244,0)
;
"RTN","IBNCPDP1",245,0)
S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D
"RTN","IBNCPDP1",246,0)
. S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D
"RTN","IBNCPDP1",247,0)
.. N IBDAT,IBPL,IBINSN,IBPIEN,IBY,IBZ,IBCHNM,IBREL,IBPLNTYP
"RTN","IBNCPDP1",248,0)
.. S IBZ=$G(IBINS(IBT,0)) Q:IBZ=""
"RTN","IBNCPDP1",249,0)
.. S IBPL=$P(IBZ,U,18) ; plan
"RTN","IBNCPDP1",250,0)
.. Q:'IBPL
"RTN","IBNCPDP1",251,0)
.. Q:'$$PLCOV^IBCNSU3(IBPL,IBADT,3) ; not a pharmacy plan
"RTN","IBNCPDP1",252,0)
.. I $G(IBD("PLAN")) Q:IBPL'=$G(IBD("PLAN")) ; skip other plans if we call RX API for a specific plan (IBD("PLAN"))
"RTN","IBNCPDP1",253,0)
.. ;
"RTN","IBNCPDP1",254,0)
.. ; at this point we have found an Rx policy. We'll count these up later by IBX.
"RTN","IBNCPDP1",255,0)
.. S IBRXPOL(IBX,IBT)=""
"RTN","IBNCPDP1",256,0)
.. ;
"RTN","IBNCPDP1",257,0)
.. S IBPLNTYP=$P($G(^IBE(355.1,+$P($G(IBINS(IBT,355.3)),U,9),0)),U,1) ; type of plan name, insurance plan type
"RTN","IBNCPDP1",258,0)
.. I '$G(IBD("PLAN")) I '$D(IBD("INS",IBX)),$P(IBRT,U,3)="V",(IBPLNTYP["TRICARE"!(IBPLNTYP="CHAMPVA")) S IBERMSG(IBX)=IBPLNTYP_" coverage for a Veteran" Q
"RTN","IBNCPDP1",259,0)
.. ;
"RTN","IBNCPDP1",260,0)
.. S IBPIEN=+$G(^IBA(355.3,+IBPL,6))
"RTN","IBNCPDP1",261,0)
.. I 'IBPIEN S IBERMSG(IBX)="Plan not linked to the Payer" Q ; Not linked
"RTN","IBNCPDP1",262,0)
.. ;
"RTN","IBNCPDP1",263,0)
.. K IBY D STCHK^IBCNRU1(IBPIEN,.IBY,IBELIG)
"RTN","IBNCPDP1",264,0)
.. I $E($G(IBY(1)))'="A" S IBERMSG(IBX)=$$ERMSG^IBNCPNB($G(IBY(6))) Q ; not active
"RTN","IBNCPDP1",265,0)
.. ;
"RTN","IBNCPDP1",266,0)
.. ; at this point we have a valid policy for this IBX
"RTN","IBNCPDP1",267,0)
.. S IBERMSG(IBX)="" ; no error message
"RTN","IBNCPDP1",268,0)
.. S IBINSN=$P($G(^DIC(36,+$G(^IBA(355.3,+IBPL,0)),0)),U) ; ins name
"RTN","IBNCPDP1",269,0)
.. S IBCHNM=$$NAME^IBCEFG1($P(IBZ,U,17)) ; standardize subscriber/cardholder name
"RTN","IBNCPDP1",270,0)
.. S IBREL=+$P($G(IBINS(IBT,4)),U,5) ; pointer to pharmacy relationship code file
"RTN","IBNCPDP1",271,0)
.. ; use the #4.05 field if it exists, otherwise use the old pt relationship field #16
"RTN","IBNCPDP1",272,0)
.. S IBREL=$S(IBREL:$$EXTERNAL^DILFD(2.312,4.05,,IBREL),1:$P(IBZ,U,16))
"RTN","IBNCPDP1",273,0)
.. ;
"RTN","IBNCPDP1",274,0)
.. S IBDAT=""
"RTN","IBNCPDP1",275,0)
.. S $P(IBDAT,U,1)=IBPL ; Plan IEN
"RTN","IBNCPDP1",276,0)
.. S $P(IBDAT,U,2)=$G(IBY(2)) ; BIN
"RTN","IBNCPDP1",277,0)
.. S $P(IBDAT,U,3)=$G(IBY(3)) ; PCN
"RTN","IBNCPDP1",278,0)
.. S $P(IBDAT,U,4)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",1),0)),U) ; Payer Sheet B1 name
"RTN","IBNCPDP1",279,0)
.. S $P(IBDAT,U,5)=$P($G(IBINS(IBT,355.3)),U,4) ; Group ID
"RTN","IBNCPDP1",280,0)
.. S $P(IBDAT,U,6)=$P(IBZ,U,2) ; Cardholder ID
"RTN","IBNCPDP1",281,0)
.. S $P(IBDAT,U,7)=IBREL ; Patient Relationship Code
"RTN","IBNCPDP1",282,0)
.. S $P(IBDAT,U,8)=$P(IBCHNM,U,2) ; Cardholder First Name
"RTN","IBNCPDP1",283,0)
.. S $P(IBDAT,U,9)=$P(IBCHNM,U,1) ; Cardholder Last Name
"RTN","IBNCPDP1",284,0)
.. S $P(IBDAT,U,10)=$P($G(^DIC(36,+IBZ,.11)),U,5) ; State
"RTN","IBNCPDP1",285,0)
.. S $P(IBDAT,U,11)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",2),0)),U) ; Payer Sheet B2 name
"RTN","IBNCPDP1",286,0)
.. S $P(IBDAT,U,12)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",3),0)),U) ; Payer Sheet B3 name
"RTN","IBNCPDP1",287,0)
.. S $P(IBDAT,U,13)=$G(IBY(4)) ; Software/Vendor Cert ID
"RTN","IBNCPDP1",288,0)
.. S $P(IBDAT,U,14)=IBINSN ; Ins Name
"RTN","IBNCPDP1",289,0)
.. S $P(IBDAT,U,15)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",4),0)),U) ; Payer Sheet E1 name
"RTN","IBNCPDP1",290,0)
.. S $P(IBDAT,U,16)=+$P($G(IBY(5)),",",1) ; Payer Sheet B1 ien
"RTN","IBNCPDP1",291,0)
.. S $P(IBDAT,U,17)=+$P($G(IBY(5)),",",2) ; Payer Sheet B2 ien
"RTN","IBNCPDP1",292,0)
.. S $P(IBDAT,U,18)=+$P($G(IBY(5)),",",3) ; Payer Sheet B3 ien
"RTN","IBNCPDP1",293,0)
.. S $P(IBDAT,U,19)=+$P($G(IBY(5)),",",4) ; Payer Sheet E1 ien
"RTN","IBNCPDP1",294,0)
.. S $P(IBDAT,U,20)=$P($G(IBINS(IBT,4)),U,6) ; Pharmacy Person Code
"RTN","IBNCPDP1",295,0)
.. S IBD("INS",IBX,1)=IBDAT
"RTN","IBNCPDP1",296,0)
.. ;
"RTN","IBNCPDP1",297,0)
.. S IBDAT=""
"RTN","IBNCPDP1",298,0)
.. S $P(IBDAT,U,1)=$P($G(IBINS(IBT,355.3)),U,3) ;group name
"RTN","IBNCPDP1",299,0)
.. S $P(IBDAT,U,2)=$$PHONE^IBNCPDP6(+IBZ) ;ins co ph 3
"RTN","IBNCPDP1",300,0)
.. S $P(IBDAT,U,3)=$$GET1^DIQ(366.03,IBPIEN_",",.01) ;plan ID
"RTN","IBNCPDP1",301,0)
.. S $P(IBDAT,U,4)=$S(IBPLNTYP="TRICARE":"T",IBPLNTYP="CHAMPVA":"C",1:"V") ; plan type
"RTN","IBNCPDP1",302,0)
.. S $P(IBDAT,U,5)=+$G(^IBA(355.3,+IBPL,0)) ; insurance co ien
"RTN","IBNCPDP1",303,0)
.. S $P(IBDAT,U,6)=$P(IBZ,U,20) ;(#.2) COB field of the (#.3121) insurance Type multiple of the Patient file (#2)
"RTN","IBNCPDP1",304,0)
.. S $P(IBDAT,U,7)=IBT ; 2.312 subfile ien
"RTN","IBNCPDP1",305,0)
.. S $P(IBDAT,U,8)=$$GET1^DIQ(366.03,IBPIEN_",",10.1) ; maximum ncpdp transactions
"RTN","IBNCPDP1",306,0)
.. S IBD("INS",IBX,3)=IBDAT
"RTN","IBNCPDP1",307,0)
.. Q
"RTN","IBNCPDP1",308,0)
. Q
"RTN","IBNCPDP1",309,0)
;
"RTN","IBNCPDP1",310,0)
; Count the number of pharmacy insurance policies by IBX found up above
"RTN","IBNCPDP1",311,0)
S IBX=0 F IBCNT=0:1 S IBX=$O(IBRXPOL(IBX)) Q:'IBX
"RTN","IBNCPDP1",312,0)
;
"RTN","IBNCPDP1",313,0)
; Determine the value of the IBX variable here. This is basically the COB sequence# to be used.
"RTN","IBNCPDP1",314,0)
; If there is only 1 pharmacy policy or no pharmacy policies, then set IBX in this manner
"RTN","IBNCPDP1",315,0)
I IBCNT'>1 D
"RTN","IBNCPDP1",316,0)
. I $D(IBD("INS")) S IBX=+$O(IBD("INS",0)) ; use the only one in this array
"RTN","IBNCPDP1",317,0)
. I '$D(IBD("INS")) S IBX=+$O(IBERMSG(0)) ; the only one here (or 0)
"RTN","IBNCPDP1",318,0)
. Q
"RTN","IBNCPDP1",319,0)
;
"RTN","IBNCPDP1",320,0)
; If there are multiple pharmacy policies on file, then the COB field in the pt. policy must be used correctly
"RTN","IBNCPDP1",321,0)
; and primary insurance must be at #1
"RTN","IBNCPDP1",322,0)
I IBCNT>1 S IBX=1
"RTN","IBNCPDP1",323,0)
;
"RTN","IBNCPDP1",324,0)
; In all cases, if this variable is set, then use it
"RTN","IBNCPDP1",325,0)
I $G(IBD("RXCOB"))>1 S IBX=$G(IBD("RXCOB"))
"RTN","IBNCPDP1",326,0)
;
"RTN","IBNCPDP1",327,0)
; Check insurance at IBX
"RTN","IBNCPDP1",328,0)
I '$D(IBD("INS",IBX)),$G(IBERMSG(IBX))'="" S IBRES="0^Not ECME billable: "_IBERMSG(IBX),IBD("NO ECME INSURANCE")=1 G SETINX
"RTN","IBNCPDP1",329,0)
I '$D(IBD("INS",IBX)) S IBRES="0^No Insurance ECME billable",IBD("NO ECME INSURANCE")=1
"RTN","IBNCPDP1",330,0)
SETINX ;
"RTN","IBNCPDP1",331,0)
Q
"RTN","IBNCPDP1",332,0)
;
"RTN","IBNCPDP1",333,0)
RXPCT(IBD,BWHERE) ; Penny drug cost calculation
"RTN","IBNCPDP1",334,0)
; Input-IBD array, BWHERE
"RTN","IBNCPDP1",335,0)
; Output-return quotient of drug true value with 4 decimal places, or 0
"RTN","IBNCPDP1",336,0)
N IBDIEN,IBDRX,IBNDC,IBFRM,IBDRFL,IBUNIT,IBSYN,IBQUO,IBDQUO,IBPSUF,IBPORD,IBPDISP,IBDRUG
"RTN","IBNCPDP1",337,0)
S IBDIEN=IBD("IEN"),IBNDC=IBD("NDC"),IBDRX=IBD("DRUG"),IBDRFL=IBD("FILL NUMBER")
"RTN","IBNCPDP1",338,0)
S IBFRM=$G(BWHERE),IBQUO=0
"RTN","IBNCPDP1",339,0)
G:'IBDRX RXPCTQ
"RTN","IBNCPDP1",340,0)
; default unit price from (50-13/15)
"RTN","IBNCPDP1",341,0)
D GETS^DIQ(50,IBDRX,".01;13;15","I","IBUNIT")
"RTN","IBNCPDP1",342,0)
S IBPORD=$G(IBUNIT(50,IBDRX_",",13,"I"))
"RTN","IBNCPDP1",343,0)
S IBPDISP=$G(IBUNIT(50,IBDRX_",",15,"I"))
"RTN","IBNCPDP1",344,0)
S (IBDQUO,IBQUO)=$S(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0)
"RTN","IBNCPDP1",345,0)
;
"RTN","IBNCPDP1",346,0)
; unit price from (50.1-402/403) if NDC exists in the SYNONYM subfile
"RTN","IBNCPDP1",347,0)
D DATA^IBRXUTL(IBDRX)
"RTN","IBNCPDP1",348,0)
S IBSYN=0 F S IBSYN=$O(^TMP($J,"IBDRUG",IBDRX,"SYN",IBSYN)) Q:'IBSYN D
"RTN","IBNCPDP1",349,0)
. I IBNDC'="",$G(^TMP($J,"IBDRUG",IBDRX,"SYN",IBSYN,2))=IBNDC D
"RTN","IBNCPDP1",350,0)
.. S IBPSUF=IBSYN_","_IBDRX_","
"RTN","IBNCPDP1",351,0)
.. D GETS^DIQ(50.1,IBPSUF,".01;402;403","I","IBUNIT")
"RTN","IBNCPDP1",352,0)
.. S IBPORD=$G(IBUNIT(50.1,IBPSUF,402,"I"))
"RTN","IBNCPDP1",353,0)
.. S IBPDISP=$G(IBUNIT(50.1,IBPSUF,403,"I"))
"RTN","IBNCPDP1",354,0)
.. S IBQUO=$S(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0)
"RTN","IBNCPDP1",355,0)
;
"RTN","IBNCPDP1",356,0)
; API #4970 - use the default unit price for CMOP
"RTN","IBNCPDP1",357,0)
I $$MWC^PSOBPSU2(IBDIEN,IBDRFL)="C" D
"RTN","IBNCPDP1",358,0)
. Q:(IBFRM="PE")!(IBFRM="PP")
"RTN","IBNCPDP1",359,0)
. S IBQUO=IBDQUO
"RTN","IBNCPDP1",360,0)
; set the lowest value 0.0001 with 4 decimal if less than 0.00005
"RTN","IBNCPDP1",361,0)
I IBQUO S IBQUO=$J(IBQUO,1,4),IBQUO=$S(IBQUO>0:IBQUO,1:"0.0001")
"RTN","IBNCPDP1",362,0)
K ^TMP($J,"IBDRUG")
"RTN","IBNCPDP1",363,0)
RXPCTQ ;
"RTN","IBNCPDP1",364,0)
Q IBQUO
"RTN","IBNCPDP1",365,0)
;
"RTN","IBNCPDP1",366,0)
EXEMPT ; exemption reasons
"RTN","IBNCPDP1",367,0)
; variable from SD call ^ variable from PSO ^ reason not billable
"RTN","IBNCPDP1",368,0)
;;1^AO^AGENT ORANGE
"RTN","IBNCPDP1",369,0)
;;2^IR^IONIZING RADIATION
"RTN","IBNCPDP1",370,0)
;;3^SC^SC TREATMENT
"RTN","IBNCPDP1",371,0)
;;4^SWA^SOUTHWEST ASIA
"RTN","IBNCPDP1",372,0)
;;5^MST^MILITARY SEXUAL TRAUMA
"RTN","IBNCPDP1",373,0)
;;6^HNC^HEAD/NECK CANCER
"RTN","IBNCPDP1",374,0)
;;7^CV^COMBAT VETERAN
"RTN","IBNCPDP1",375,0)
;;8^SHAD^PROJECT 112/SHAD
"RTN","IBNCPDP1",376,0)
;;
"RTN","IBNCPDP1",377,0)
;
"RTN","IBNCPDPU")
0^1^B133189432
"RTN","IBNCPDPU",1,0)
IBNCPDPU ;OAK/ELZ - UTILITIES FOR NCPDP ;Jun 06, 2014@19:13:12
"RTN","IBNCPDPU",2,0)
;;2.0;INTEGRATED BILLING;**223,276,347,383,405,384,437,435,452,511,534,550,624**;21-MAR-94;Build 8
"RTN","IBNCPDPU",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBNCPDPU",4,0)
;
"RTN","IBNCPDPU",5,0)
;Reference to ECMEACT^PSOBPSU1 supported by IA# 4702
"RTN","IBNCPDPU",6,0)
;Reference to $$EN^BPSNCPDP supported by IA# 4415
"RTN","IBNCPDPU",7,0)
;Reference to $$NABP^BPSBUTL supported by IA# 4719
"RTN","IBNCPDPU",8,0)
;Reference to $$CLMECME^BPSUTIL2 supported by IA# 6028
"RTN","IBNCPDPU",9,0)
;Reference to $$VALECME^BPSUTIL2 supported by IA# 6139
"RTN","IBNCPDPU",10,0)
;Reference to $$RXRLDT^PSOBPSUT supported by IA# 4701
"RTN","IBNCPDPU",11,0)
;
"RTN","IBNCPDPU",12,0)
;
"RTN","IBNCPDPU",13,0)
CT(DFN,IBRXN,IBFIL,IBADT,IBRMARK) ; files in claims tracking
"RTN","IBNCPDPU",14,0)
; Input:
"RTN","IBNCPDPU",15,0)
; DFN - Patient IEN
"RTN","IBNCPDPU",16,0)
; IBRXN - Rx IEN
"RTN","IBNCPDPU",17,0)
; IBFIL - Fill#
"RTN","IBNCPDPU",18,0)
; IBADT - Date of Service
"RTN","IBNCPDPU",19,0)
; IBRMARK - Non-billable Reason (.01 from 356.8)
"RTN","IBNCPDPU",20,0)
;
"RTN","IBNCPDPU",21,0)
N DIE,DR,DA,IBRXTYP,IBEABD
"RTN","IBNCPDPU",22,0)
; Check that the Date of Service is current
"RTN","IBNCPDPU",23,0)
I IBTRKRN,$G(IBADT),($G(IBADT)'=$P(^IBT(356,IBTRKRN,0),U,6)) D
"RTN","IBNCPDPU",24,0)
. S DIE="^IBT(356,",DA=IBTRKRN,DR=".06////"_IBADT D ^DIE
"RTN","IBNCPDPU",25,0)
I IBTRKRN D:$D(IBRMARK) Q
"RTN","IBNCPDPU",26,0)
. S DIE="^IBT(356,",DA=IBTRKRN,DR=".19///"_IBRMARK
"RTN","IBNCPDPU",27,0)
. D ^DIE
"RTN","IBNCPDPU",28,0)
; event type pointer for rx billing
"RTN","IBNCPDPU",29,0)
S IBRXTYP=$O(^IBE(356.6,"AC",4,0))
"RTN","IBNCPDPU",30,0)
; earliest auto-billing date
"RTN","IBNCPDPU",31,0)
S IBEABD=$$EABD^IBTUTL(IBRXTYP,$$FMADD^XLFDT(IBADT,60))
"RTN","IBNCPDPU",32,0)
; space out earliest auto bill date
"RTN","IBNCPDPU",33,0)
;
"RTN","IBNCPDPU",34,0)
; ROI check. The variable IBSCROI will be set to:
"RTN","IBNCPDPU",35,0)
; '1' if NOT REQUIRED '2' if OBTAINED
"RTN","IBNCPDPU",36,0)
; '3' if REQUIRED '4' if REFUSED
"RTN","IBNCPDPU",37,0)
N IBSCROI,IBDRUG,IBDEA,IBRXDATA
"RTN","IBNCPDPU",38,0)
S IBRXDATA=$$RXZERO^IBRXUTL(DFN,IBRXN)
"RTN","IBNCPDPU",39,0)
S IBDRUG=$P(IBRXDATA,U,6)
"RTN","IBNCPDPU",40,0)
;
"RTN","IBNCPDPU",41,0)
;$$SENS^IBNCPDR returns 1 if the drug is sensitive diagnosis drug
"RTN","IBNCPDPU",42,0)
I $$SENS^IBNCPDR(IBDRUG) D
"RTN","IBNCPDPU",43,0)
. N IBINS,IBFLG,IBINSP
"RTN","IBNCPDPU",44,0)
. D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
"RTN","IBNCPDPU",45,0)
. S IBINSP=$O(IBINS("S",1,99),-1) Q:IBINSP=""
"RTN","IBNCPDPU",46,0)
. ;Check to see if the Date of Service (DOS) is on or after to the Mission Act Implementation
"RTN","IBNCPDPU",47,0)
. ; Date (MAID). $$MACHK^IBNCPDR4 returns 1 if the DOS is on or after MAID. If 1 is returned
"RTN","IBNCPDPU",48,0)
. ; set (IBFLG,IBSCROI)=1 and IBRMARK="" (file 356,#.19 NON-BILLABLE REASON)
"RTN","IBNCPDPU",49,0)
. I $$MACHK^IBNCPDR4($G(IBADT)) S (IBFLG,IBSCROI)=1,IBRMARK="" Q
"RTN","IBNCPDPU",50,0)
. S IBFLG=$$ROI^IBNCPDR4(DFN,$G(IBDRUG),+$G(IBINS(IBINSP,"0")),$G(IBADT))
"RTN","IBNCPDPU",51,0)
. I 'IBFLG,$G(IBRMARK)="" S IBRMARK="ROI NOT OBTAINED" ; IB*2*550
"RTN","IBNCPDPU",52,0)
. I 'IBFLG S IBSCROI=3
"RTN","IBNCPDPU",53,0)
. I IBFLG S IBSCROI=2
"RTN","IBNCPDPU",54,0)
;
"RTN","IBNCPDPU",55,0)
D REFILL^IBTUTL1(DFN,IBRXTYP,IBADT,IBRXN,IBFIL,$G(IBRMARK),IBEABD,$G(IBSCROI))
"RTN","IBNCPDPU",56,0)
Q
"RTN","IBNCPDPU",57,0)
;
"RTN","IBNCPDPU",58,0)
;NDC relocated to IBNCPNB
"RTN","IBNCPDPU",59,0)
;
"RTN","IBNCPDPU",60,0)
FILL(X,LEN) ; Zero-fill, right justified.
"RTN","IBNCPDPU",61,0)
N Y
"RTN","IBNCPDPU",62,0)
S:'$G(LEN) LEN=1
"RTN","IBNCPDPU",63,0)
S Y=$E($G(X),1,LEN)
"RTN","IBNCPDPU",64,0)
F Q:$L(Y)>(LEN-1) S Y="0"_Y
"RTN","IBNCPDPU",65,0)
Q Y
"RTN","IBNCPDPU",66,0)
;
"RTN","IBNCPDPU",67,0)
PLANN(DFN,IBX,IBADT) ; returns the ien in the insurance multiple for the given plan/patient provided
"RTN","IBNCPDPU",68,0)
; Output: insurance co ien^2.312 subfile ien
"RTN","IBNCPDPU",69,0)
N IBPOL,IBY,IBR
"RTN","IBNCPDPU",70,0)
S IBR=""
"RTN","IBNCPDPU",71,0)
D ALL^IBCNS1(DFN,"IBPOL",1,IBADT)
"RTN","IBNCPDPU",72,0)
S IBY=0 F S IBY=$O(IBPOL(IBY)) Q:'IBY!IBR I $P($G(IBPOL(IBY,0)),U,18)=IBX S IBR=$P(IBPOL(IBY,0),U,1)_U_IBY Q
"RTN","IBNCPDPU",73,0)
Q IBR
"RTN","IBNCPDPU",74,0)
;
"RTN","IBNCPDPU",75,0)
PLANEPS(IBPL) ; returns the ePharmacy payer sheets for a group plan
"RTN","IBNCPDPU",76,0)
; IBPL = IEN to GROUP INSURANCE PLAN file #355.3
"RTN","IBNCPDPU",77,0)
; Returns: Payer Sheets. (B1,B2,B3,E1) (comma separated string)
"RTN","IBNCPDPU",78,0)
; Successful: 1^B1,B2,B3,E1
"RTN","IBNCPDPU",79,0)
; Unsuccessful: 0
"RTN","IBNCPDPU",80,0)
N PIEN,IBR,PLN10,B1,B2,B3,E1
"RTN","IBNCPDPU",81,0)
S IBR=0
"RTN","IBNCPDPU",82,0)
I '$G(IBPL) Q IBR
"RTN","IBNCPDPU",83,0)
; Get ePharmacy plan IEN
"RTN","IBNCPDPU",84,0)
S PIEN=+$P($G(^IBA(355.3,IBPL,6)),U,1)
"RTN","IBNCPDPU",85,0)
I 'PIEN Q IBR
"RTN","IBNCPDPU",86,0)
S PLN10=$G(^IBCNR(366.03,PIEN,10))
"RTN","IBNCPDPU",87,0)
; check for test/production sheets
"RTN","IBNCPDPU",88,0)
; get the test payer sheet first. If nil, then get the regular payer sheet
"RTN","IBNCPDPU",89,0)
S (B1,B2,B3,E1)=""
"RTN","IBNCPDPU",90,0)
S B1=$P(PLN10,U,11),B2=$P(PLN10,U,12),B3=$P(PLN10,U,13),E1=$P(PLN10,U,14)
"RTN","IBNCPDPU",91,0)
I 'B1 S B1=$P(PLN10,U,7) ; billing
"RTN","IBNCPDPU",92,0)
I 'B2 S B2=$P(PLN10,U,8) ; reversal
"RTN","IBNCPDPU",93,0)
I 'B3 S B3=$P(PLN10,U,9) ; rebill (not currently validated)
"RTN","IBNCPDPU",94,0)
I 'E1 S E1=$P(PLN10,U,15) ; eligibility
"RTN","IBNCPDPU",95,0)
S IBR="1^"_B1_","_B2_","_B3_","_E1
"RTN","IBNCPDPU",96,0)
Q IBR
"RTN","IBNCPDPU",97,0)
;
"RTN","IBNCPDPU",98,0)
RT(DFN,IBDT,IBINS,IBPTYP) ; returns rate type to use for bill
"RTN","IBNCPDPU",99,0)
; Input:
"RTN","IBNCPDPU",100,0)
; DFN - patient ien
"RTN","IBNCPDPU",101,0)
; IBDT - date of service
"RTN","IBNCPDPU",102,0)
; IBINS - insurance array (pass by reference)
"RTN","IBNCPDPU",103,0)
;
"RTN","IBNCPDPU",104,0)
; Output:
"RTN","IBNCPDPU",105,0)
; 3 piece string in the following format
"RTN","IBNCPDPU",106,0)
; [1] rate type ien
"RTN","IBNCPDPU",107,0)
; [2] Rate Type (Tort or Awp or Cost)
"RTN","IBNCPDPU",108,0)
; [3] Eligibility Basis (V=VETERAN, T=TRICARE, C=CHAMPVA)
"RTN","IBNCPDPU",109,0)
;
"RTN","IBNCPDPU",110,0)
; IBPTYP - patient type - optional output parameter (pass by reference)
"RTN","IBNCPDPU",111,0)
; - this is only used by the PRO option (see IBNCPDP1)
"RTN","IBNCPDPU",112,0)
; - (V=VETERAN, T=TRICARE, C=CHAMPVA)
"RTN","IBNCPDPU",113,0)
; - NOT the same thing as [3] of this function
"RTN","IBNCPDPU",114,0)
;
"RTN","IBNCPDPU",115,0)
N IBPT,IBRT,IBE,IBI,IBRET,IBRS,IBX,VAEL,VAERR
"RTN","IBNCPDPU",116,0)
S IBPTYP=""
"RTN","IBNCPDPU",117,0)
D ELIG^VADPT
"RTN","IBNCPDPU",118,0)
;
"RTN","IBNCPDPU",119,0)
; if primary elig is vet type, use reimbursable
"RTN","IBNCPDPU",120,0)
S IBPT=$P($G(^DIC(8,+VAEL(1),0)),U,5) ; = N:NON-VETERAN;Y:VETERAN
"RTN","IBNCPDPU",121,0)
I IBPT="Y" D Q IBRT_U_$S($G(IBRET)="VA COST":"C^V",1:"T^V") ; IB*2*437 modifications
"RTN","IBNCPDPU",122,0)
. S IBRT=$O(^DGCR(399.3,"B","REIMBURSABLE INS.",0))
"RTN","IBNCPDPU",123,0)
. S IBRT=$S(IBRT:IBRT,1:8)
"RTN","IBNCPDPU",124,0)
. I $G(IBDT) S IBRET=$P($$EVNTITM^IBCRU3(IBRT,3,"PRESCRIPTION FILL",IBDT,.IBRS),";",1)
"RTN","IBNCPDPU",125,0)
. Q
"RTN","IBNCPDPU",126,0)
;
"RTN","IBNCPDPU",127,0)
; ia #'s 427 & 2516 for references to ^DIC(8 and ^DIC(8.1
"RTN","IBNCPDPU",128,0)
;
"RTN","IBNCPDPU",129,0)
; - determine eligibilities - build the IBE array
"RTN","IBNCPDPU",130,0)
S IBE=$P($G(^DIC(8.1,+$P($G(^DIC(8,+VAEL(1),0)),U,9),0)),U,1),IBE($S(IBE="TRICARE"!(IBE="SHARING AGREEMENT"):"T",IBE="CHAMPVA":"C",1:"O"))="" ; primary pt eligibility
"RTN","IBNCPDPU",131,0)
; IB*2*452 - for CHAMPVA, CHAMPVA must be primary eligibility only - not among secondary eligibilities
"RTN","IBNCPDPU",132,0)
S IBX=0 F S IBX=$O(VAEL(1,IBX)) Q:'IBX S IBE=$P($G(^DIC(8.1,+$P($G(^DIC(8,+VAEL(1,IBX),0)),U,9),0)),U,1) S IBE($S(IBE="TRICARE"!(IBE="SHARING AGREEMENT"):"T",1:"O"))="" ; secondary pt eligibilities
"RTN","IBNCPDPU",133,0)
;
"RTN","IBNCPDPU",134,0)
; set patient type parameter
"RTN","IBNCPDPU",135,0)
I $G(VAEL(4)) S IBPTYP="V" ; veteran without any pt. eligibilities defined
"RTN","IBNCPDPU",136,0)
I $D(IBE("T")) S IBPTYP="T" ; TRICARE
"RTN","IBNCPDPU",137,0)
I $D(IBE("C")) S IBPTYP="C" ; CHAMPVA
"RTN","IBNCPDPU",138,0)
;
"RTN","IBNCPDPU",139,0)
; - determine insurance policies - build the IBI array
"RTN","IBNCPDPU",140,0)
S IBX=0 F S IBX=$O(IBINS(IBX)) Q:'IBX S IBI=$P($G(^IBE(355.1,+$P($G(IBINS(IBX,355.3)),U,9),0)),U,1) S IBI($S(IBI="TRICARE":"T",IBI="CHAMPVA":"C",1:"O"))=""
"RTN","IBNCPDPU",141,0)
;
"RTN","IBNCPDPU",142,0)
; If patient is only TRICARE eligible, and has TRICARE insurance,
"RTN","IBNCPDPU",143,0)
; regardless of the presence of other insurance, set eligibility to
"RTN","IBNCPDPU",144,0)
; TRICARE and Quit.
"RTN","IBNCPDPU",145,0)
I $D(IBE("T")),'$D(IBE("O")),'$D(IBE("C")),$D(IBI("T")) S IBRT=$O(^DGCR(399.3,"B","TRICARE",0)) Q:IBRT IBRT_"^C^T"
"RTN","IBNCPDPU",146,0)
;
"RTN","IBNCPDPU",147,0)
; IB*2*452 - check for CHAMPVA
"RTN","IBNCPDPU",148,0)
I $D(IBE("C")),$D(IBI("C")) S IBRT=$O(^DGCR(399.3,"B","CHAMPVA",0)) Q:IBRT IBRT_"^C^C"
"RTN","IBNCPDPU",149,0)
;
"RTN","IBNCPDPU",150,0)
Q "0^unable to determine rate type"
"RTN","IBNCPDPU",151,0)
;
"RTN","IBNCPDPU",152,0)
;
"RTN","IBNCPDPU",153,0)
BS() ; returns the mccr utility to use
"RTN","IBNCPDPU",154,0)
N IBX
"RTN","IBNCPDPU",155,0)
S IBX=0 F S IBX=$O(^DGCR(399.1,"B","PRESCRIPTION",IBX)) Q:IBX<1 I $P($G(^DGCR(399.1,+$G(IBX),0)),U,5) Q
"RTN","IBNCPDPU",156,0)
Q IBX
"RTN","IBNCPDPU",157,0)
;
"RTN","IBNCPDPU",158,0)
RXBIL(IBINP,IBERR) ; Matching NCPDP payments
"RTN","IBNCPDPU",159,0)
; Find IB Bill by the 7 or 12 digit ECME number and the Rx fill date
"RTN","IBNCPDPU",160,0)
; This function is called by AR routine $$BILL^RCDPESR1 (DBIA 4435).
"RTN","IBNCPDPU",161,0)
;Input:
"RTN","IBNCPDPU",162,0)
; IBINP("ECME") - the 7 or 12 digit ECME number (Reference Number)
"RTN","IBNCPDPU",163,0)
; IBINP("FILLDT") - the Rx fill date, YYYYMMDD or FileMan format
"RTN","IBNCPDPU",164,0)
; IBINP("PNM") (optional) - the patient's last name
"RTN","IBNCPDPU",165,0)
;Returns:
"RTN","IBNCPDPU",166,0)
; IBERR (by ref) - the error code, or null string if found
"RTN","IBNCPDPU",167,0)
; RXBIL - IB Bill IEN, or 0 if not matched
"RTN","IBNCPDPU",168,0)
N IBECME,BILLDA,IBDAT,IBPNAME,BPSDAT
"RTN","IBNCPDPU",169,0)
S IBERR=""
"RTN","IBNCPDPU",170,0)
S IBECME=$G(IBINP("ECME"))
"RTN","IBNCPDPU",171,0)
I '$$VALECME^BPSUTIL2(IBECME) S IBERR="Invalid ECME number" Q 0
"RTN","IBNCPDPU",172,0)
S IBDAT=$G(IBINP("FILLDT")) ; Rx fill date
"RTN","IBNCPDPU",173,0)
I IBDAT?8N S IBDAT=($E(IBDAT,1,4)-1700)_$E(IBDAT,5,8) ; conv date to FM format
"RTN","IBNCPDPU",174,0)
I IBDAT'?7N Q $$RXBILND(IBECME) ; date is not correct or null
"RTN","IBNCPDPU",175,0)
S IBPNAME=$G(IBINP("PNM")) ; patient's name (optional)
"RTN","IBNCPDPU",176,0)
S BILLDA=$$ECMEMTCH(IBECME,IBDAT,IBPNAME,.IBERR)
"RTN","IBNCPDPU",177,0)
I 'BILLDA S BPSDAT=$$CLMECME^BPSUTIL2(+IBECME,IBDAT) I $G(BPSDAT)>0,BPSDAT'=IBDAT S BILLDA=$$ECMEMTCH(IBECME,BPSDAT,IBPNAME,.IBERR)
"RTN","IBNCPDPU",178,0)
Q +BILLDA
"RTN","IBNCPDPU",179,0)
;
"RTN","IBNCPDPU",180,0)
RXBILND(IBECME) ;Match the bill with no date
"RTN","IBNCPDPU",181,0)
N IBKEY,IBBC,BILLDA,IBY,IBCUT,ECMELEN,ECMENUM
"RTN","IBNCPDPU",182,0)
S IBCUT=$$FMADD^XLFDT(DT,-180) ; only 180 days in the past for cut-off date
"RTN","IBNCPDPU",183,0)
;
"RTN","IBNCPDPU",184,0)
; Search ECME# 7/12 digits forward looking for PRNT/TX claims (IB*2*435)
"RTN","IBNCPDPU",185,0)
S BILLDA=0
"RTN","IBNCPDPU",186,0)
F ECMELEN=12,7 D Q:BILLDA
"RTN","IBNCPDPU",187,0)
. I $L(+IBECME)>ECMELEN Q ; Quit if too large
"RTN","IBNCPDPU",188,0)
. S ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME#
"RTN","IBNCPDPU",189,0)
. S IBKEY=ECMENUM_";"
"RTN","IBNCPDPU",190,0)
. S IBBC=IBKEY_IBCUT
"RTN","IBNCPDPU",191,0)
. F S IBBC=$O(^DGCR(399,"AG",IBBC)) Q:IBBC'[IBKEY D Q:BILLDA
"RTN","IBNCPDPU",192,0)
.. S IBY="" F S IBY=$O(^DGCR(399,"AG",IBBC,IBY)) Q:'IBY D Q:BILLDA
"RTN","IBNCPDPU",193,0)
... I $P($G(^DGCR(399,+IBY,0)),U,13)'=4 Q ; not PRNT/TX
"RTN","IBNCPDPU",194,0)
... S BILLDA=+IBY
"RTN","IBNCPDPU",195,0)
... Q
"RTN","IBNCPDPU",196,0)
.. Q
"RTN","IBNCPDPU",197,0)
. Q
"RTN","IBNCPDPU",198,0)
;
"RTN","IBNCPDPU",199,0)
I BILLDA Q BILLDA
"RTN","IBNCPDPU",200,0)
;
"RTN","IBNCPDPU",201,0)
; Search ECME# 7/12 digits backwards looking for ANY claims within cut-off date (IB*2*435)
"RTN","IBNCPDPU",202,0)
S BILLDA=0
"RTN","IBNCPDPU",203,0)
F ECMELEN=12,7 D Q:BILLDA
"RTN","IBNCPDPU",204,0)
. I $L(+IBECME)>ECMELEN Q ; Quit if too large
"RTN","IBNCPDPU",205,0)
. S ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME#
"RTN","IBNCPDPU",206,0)
. S IBKEY=ECMENUM_";"
"RTN","IBNCPDPU",207,0)
. S IBBC=IBKEY_"8000000"
"RTN","IBNCPDPU",208,0)
. F S IBBC=$O(^DGCR(399,"AG",IBBC),-1) Q:IBBC'[IBKEY Q:$P(IBBC,";",2)<IBCUT D Q:BILLDA
"RTN","IBNCPDPU",209,0)
.. S IBY="" F S IBY=$O(^DGCR(399,"AG",IBBC,IBY),-1) Q:IBY="" D Q:BILLDA
"RTN","IBNCPDPU",210,0)
... S BILLDA=+IBY
"RTN","IBNCPDPU",211,0)
... Q
"RTN","IBNCPDPU",212,0)
.. Q
"RTN","IBNCPDPU",213,0)
. Q
"RTN","IBNCPDPU",214,0)
;
"RTN","IBNCPDPU",215,0)
Q BILLDA
"RTN","IBNCPDPU",216,0)
;
"RTN","IBNCPDPU",217,0)
;Check matching of two strings - case insensitive, no spaces etc.
"RTN","IBNCPDPU",218,0)
TXMATCH(IBTXT1,IBTXT2,IBMAX) ;
"RTN","IBNCPDPU",219,0)
N IBTR1,IBTR2,IBT1,IBT2
"RTN","IBNCPDPU",220,0)
;Checking only first IBMAX characters (long names may be truncated)
"RTN","IBNCPDPU",221,0)
S IBTR1="ABCDEFGHIJKLMNOPQRSTUVWXYZ:;"",'._()<>/\|@#$%&*-=!`~ "
"RTN","IBNCPDPU",222,0)
S IBTR2="abcdefghijklmnopqrstuvwxyz"
"RTN","IBNCPDPU",223,0)
S IBT1=$E($TR(IBTXT1,IBTR1,IBTR2),1,IBMAX)
"RTN","IBNCPDPU",224,0)
S IBT2=$E($TR(IBTXT2,IBTR1,IBTR2),1,IBMAX)
"RTN","IBNCPDPU",225,0)
Q IBT1=IBT2
"RTN","IBNCPDPU",226,0)
;
"RTN","IBNCPDPU",227,0)
ECMEBIL(DFN,IBADT) ; Is the pat ECME Billable (pharmacy coverage only)
"RTN","IBNCPDPU",228,0)
; DFN - ptr to the patient
"RTN","IBNCPDPU",229,0)
; IBADT - the date
"RTN","IBNCPDPU",230,0)
; IBINS - insurance array returned by ALL^IBCNS1
"RTN","IBNCPDPU",231,0)
N IBANY,IBERMSG,IBX,IBINS,IBT,IBZ,IBRES,IBCAT,IBCOV,IBPCOV
"RTN","IBNCPDPU",232,0)
S IBRES=0 ; Not ECME Billable by default
"RTN","IBNCPDPU",233,0)
S (IBCOV,IBPCOV)=0
"RTN","IBNCPDPU",234,0)
; -- look up ins with Rx
"RTN","IBNCPDPU",235,0)
D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
"RTN","IBNCPDPU",236,0)
S IBERMSG="" ; Error message
"RTN","IBNCPDPU",237,0)
S IBCAT=$O(^IBE(355.31,"B","PHARMACY",0))
"RTN","IBNCPDPU",238,0)
S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D Q:IBRES
"RTN","IBNCPDPU",239,0)
. S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D Q:IBRES
"RTN","IBNCPDPU",240,0)
. . N IBZ,IBPIEN,IBY,IBPL
"RTN","IBNCPDPU",241,0)
. . S IBZ=$G(IBINS(IBT,0))
"RTN","IBNCPDPU",242,0)
. . S IBPL=+$P(IBZ,U,18) Q:'IBPL
"RTN","IBNCPDPU",243,0)
. . S IBCOV=1 ; covered
"RTN","IBNCPDPU",244,0)
. . I '$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT) Q
"RTN","IBNCPDPU",245,0)
. . S IBPCOV=1
"RTN","IBNCPDPU",246,0)
. . S IBPIEN=+$G(^IBA(355.3,IBPL,6))
"RTN","IBNCPDPU",247,0)
. . I 'IBPIEN S IBERMSG="Plan not linked to the Payer" Q ; Not linked
"RTN","IBNCPDPU",248,0)
. . D STCHK^IBCNRU1(IBPIEN,.IBY)
"RTN","IBNCPDPU",249,0)
. . I $E($G(IBY(1)))'="A" S:IBERMSG="" IBERMSG=$$ERMSG^IBNCPNB($P($G(IBY(6)),",")) Q
"RTN","IBNCPDPU",250,0)
. . S IBRES=1
"RTN","IBNCPDPU",251,0)
I 'IBCOV Q "0^Not Insured"
"RTN","IBNCPDPU",252,0)
I 'IBPCOV Q "0^No Pharmacy Coverage"
"RTN","IBNCPDPU",253,0)
I 'IBRES,IBERMSG'="" Q "0^"_IBERMSG
"RTN","IBNCPDPU",254,0)
I 'IBRES Q "0^No Insurance ECME billable"
"RTN","IBNCPDPU",255,0)
;
"RTN","IBNCPDPU",256,0)
Q IBRES
"RTN","IBNCPDPU",257,0)
;
"RTN","IBNCPDPU",258,0)
SUBMIT(IBRX,IBFIL,IBDELAY) ; Submit the Rx claim through ECME
"RTN","IBNCPDPU",259,0)
; IBDELAY - Delay Reason Code, passed as the 18th parameter - IB*2.0*435
"RTN","IBNCPDPU",260,0)
; IBRX - RX ien in file #52
"RTN","IBNCPDPU",261,0)
; IBFIL - Fill No (0 for orig fill)
"RTN","IBNCPDPU",262,0)
N IBDT,IBNDC,IBX
"RTN","IBNCPDPU",263,0)
I '$G(IBRX)!('$D(IBFIL)) Q "0^Invalid parameters."
"RTN","IBNCPDPU",264,0)
S IBDT=$$RXRLDT^PSOBPSUT(IBRX,IBFIL)\1 ; release date (DBIA# 4701)
"RTN","IBNCPDPU",265,0)
I 'IBDT!(IBDT>DT) S IBDT=DT ; if not released, use the current date (ePharmacy DOS)
"RTN","IBNCPDPU",266,0)
S IBX=$$EN^BPSNCPDP(+IBRX,+IBFIL,IBDT,"BB",,,,,,,,,,,,,,+$G(IBDELAY))
"RTN","IBNCPDPU",267,0)
I +IBX=0 D ECMEACT^PSOBPSU1(+IBRX,+IBFIL,"Claim submitted to 3rd party payer: IB BACK BILLING")
"RTN","IBNCPDPU",268,0)
Q IBX
"RTN","IBNCPDPU",269,0)
;
"RTN","IBNCPDPU",270,0)
REASON(IBX,EXACT) ; Close Claim Reasons
"RTN","IBNCPDPU",271,0)
Q $P($G(^IBE(356.8,+IBX,0)),U) ; non-billable reason
"RTN","IBNCPDPU",272,0)
;
"RTN","IBNCPDPU",273,0)
NABP(IBIFN) ;NABP Number
"RTN","IBNCPDPU",274,0)
N IBY,IBTRKN,IBRX,IBFIL,IBZ,IBNABP
"RTN","IBNCPDPU",275,0)
S IBY=+$O(^IBT(356.399,"C",IBIFN,0)) I 'IBY Q ""
"RTN","IBNCPDPU",276,0)
S IBTRKN=$P($G(^IBT(356.399,IBY,0)),U) I 'IBTRKN Q ""
"RTN","IBNCPDPU",277,0)
S IBZ=$G(^IBT(356,IBTRKN,0)) I IBZ="" Q ""
"RTN","IBNCPDPU",278,0)
S IBRX=$P(IBZ,U,8)
"RTN","IBNCPDPU",279,0)
S IBFIL=$P(IBZ,U,10)
"RTN","IBNCPDPU",280,0)
S IBNABP=$$NABP^BPSBUTL(IBRX,IBFIL)
"RTN","IBNCPDPU",281,0)
Q $S(IBNABP=0:"",1:IBNABP)
"RTN","IBNCPDPU",282,0)
;
"RTN","IBNCPDPU",283,0)
; Get the K-bill# from CT
"RTN","IBNCPDPU",284,0)
BILL(IBRX,IBFIL) ;
"RTN","IBNCPDPU",285,0)
N IBTRKN,IBIFN
"RTN","IBNCPDPU",286,0)
S IBTRKN=+$O(^IBT(356,"ARXFL",+$G(IBRX),+$G(IBFIL),""))
"RTN","IBNCPDPU",287,0)
S IBIFN=+$P($G(^IBT(356,IBTRKN,0)),U,11)
"RTN","IBNCPDPU",288,0)
Q $P($G(^DGCR(399,IBIFN,0)),U)
"RTN","IBNCPDPU",289,0)
;
"RTN","IBNCPDPU",290,0)
REJECT(IBECME,IBDATE) ; Is the e-claim rejected?
"RTN","IBNCPDPU",291,0)
N IBTRKRN,IBY,ECMELEN
"RTN","IBNCPDPU",292,0)
I IBECME'?1.12N Q 0
"RTN","IBNCPDPU",293,0)
S IBTRKRN=0
"RTN","IBNCPDPU",294,0)
F ECMELEN=12,7 D Q:IBTRKRN
"RTN","IBNCPDPU",295,0)
. I $L(+IBECME)>ECMELEN Q
"RTN","IBNCPDPU",296,0)
. S IBECME=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME# with leading zeros
"RTN","IBNCPDPU",297,0)
. S IBTRKRN=+$O(^IBT(356,"AE",IBECME,0))
"RTN","IBNCPDPU",298,0)
. Q
"RTN","IBNCPDPU",299,0)
;
"RTN","IBNCPDPU",300,0)
I 'IBTRKRN Q 0
"RTN","IBNCPDPU",301,0)
S IBY=$G(^IBT(356,IBTRKRN,1))
"RTN","IBNCPDPU",302,0)
I $P(IBY,U,11)>0 Q 1 ; Rejected or closed
"RTN","IBNCPDPU",303,0)
Q 0
"RTN","IBNCPDPU",304,0)
;
"RTN","IBNCPDPU",305,0)
RXINS(DFN,IBADT,IBINS) ; Return an array of pharmacy insurance policies by COB order
"RTN","IBNCPDPU",306,0)
; Input:
"RTN","IBNCPDPU",307,0)
; DFN - Patient ien (required)
"RTN","IBNCPDPU",308,0)
; IBADT - Date of Service (fileman format, optional defaults to today)
"RTN","IBNCPDPU",309,0)
; Output:
"RTN","IBNCPDPU",310,0)
; IBINS - Name of destination array (pass by reference)
"RTN","IBNCPDPU",311,0)
;
"RTN","IBNCPDPU",312,0)
N CT,COB,IEN,IBPL
"RTN","IBNCPDPU",313,0)
K IBINS
"RTN","IBNCPDPU",314,0)
S DFN=+$G(DFN)
"RTN","IBNCPDPU",315,0)
S IBADT=+$G(IBADT,DT)
"RTN","IBNCPDPU",316,0)
D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1) ; gather all insurance policies in COB order
"RTN","IBNCPDPU",317,0)
;
"RTN","IBNCPDPU",318,0)
S CT=0 ; count up Rx policies found
"RTN","IBNCPDPU",319,0)
S COB="" F S COB=$O(IBINS("S",COB)) Q:COB="" S IEN=0 F S IEN=$O(IBINS("S",COB,IEN)) Q:'IEN D
"RTN","IBNCPDPU",320,0)
. S IBPL=+$P($G(IBINS(IEN,0)),U,18) ; plan ien
"RTN","IBNCPDPU",321,0)
. I 'IBPL K IBINS(IEN),IBINS("S",COB,IEN) Q ; no plan
"RTN","IBNCPDPU",322,0)
. I '$$PLCOV^IBCNSU3(IBPL,IBADT,3) K IBINS(IEN),IBINS("S",COB,IEN) Q ; not a pharmacy plan
"RTN","IBNCPDPU",323,0)
. S CT=CT+1
"RTN","IBNCPDPU",324,0)
. Q
"RTN","IBNCPDPU",325,0)
;
"RTN","IBNCPDPU",326,0)
S IBINS=CT ; store total number found at the top level
"RTN","IBNCPDPU",327,0)
;
"RTN","IBNCPDPU",328,0)
RXINSX ;
"RTN","IBNCPDPU",329,0)
Q
"RTN","IBNCPDPU",330,0)
;
"RTN","IBNCPDPU",331,0)
ECMEMTCH(IBECME,IBDAT,IBPNAME,IBERR) ; Attempt ECME# look up with either 7 digit or 12 digit number (IB*2*435)
"RTN","IBNCPDPU",332,0)
N IBFOUND,IBMATCH,ECMELEN,IBKEY,BILLDA
"RTN","IBNCPDPU",333,0)
S IBFOUND=0,IBMATCH=0
"RTN","IBNCPDPU",334,0)
F ECMELEN=12,7 D Q:IBFOUND
"RTN","IBNCPDPU",335,0)
. I $L(+IBECME)>ECMELEN Q ; Quit if too large
"RTN","IBNCPDPU",336,0)
. S ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME#
"RTN","IBNCPDPU",337,0)
. S IBKEY=ECMENUM_";"_IBDAT ; The ECME Number (BC ID) for the "AG" xref
"RTN","IBNCPDPU",338,0)
. S BILLDA=""
"RTN","IBNCPDPU",339,0)
. ; Search Backward
"RTN","IBNCPDPU",340,0)
. F S BILLDA=$O(^DGCR(399,"AG",IBKEY,BILLDA),-1) Q:BILLDA="" D Q:IBFOUND
"RTN","IBNCPDPU",341,0)
.. I 'BILLDA Q ; IEN must be numeric
"RTN","IBNCPDPU",342,0)
.. I '$D(^DGCR(399,BILLDA,0)) Q ; Corrupted index
"RTN","IBNCPDPU",343,0)
.. S IBMATCH=1
"RTN","IBNCPDPU",344,0)
.. I IBPNAME'="" I '$$TXMATCH($P(IBPNAME,","),$P($G(^DPT(+$P(^DGCR(399,BILLDA,0),U,2),0)),","),8) Q ; Patient name doesn't match
"RTN","IBNCPDPU",345,0)
.. S IBFOUND=1
"RTN","IBNCPDPU",346,0)
I 'BILLDA S IBERR=$S(IBMATCH:"Patient's name does not match",1:"Matching bill not found") ; not matched
"RTN","IBNCPDPU",347,0)
Q +BILLDA
"RTN","IBNCPDPU",348,0)
;
"RTN","IBNCPDPU",349,0)
ACDUTY(DFN) ;
"RTN","IBNCPDPU",350,0)
; Check active duty status for the patient
"RTN","IBNCPDPU",351,0)
; Input:
"RTN","IBNCPDPU",352,0)
; DFN: Patient (#2) IEN
"RTN","IBNCPDPU",353,0)
; Output:
"RTN","IBNCPDPU",354,0)
; 0: Does not have an Active Duty Status
"RTN","IBNCPDPU",355,0)
; 1: Has an active Duty Status
"RTN","IBNCPDPU",356,0)
;
"RTN","IBNCPDPU",357,0)
I '$G(DFN) Q 0
"RTN","IBNCPDPU",358,0)
; Check if Patient TYPE is ACTIVE DUTY
"RTN","IBNCPDPU",359,0)
N VAEL
"RTN","IBNCPDPU",360,0)
D ELIG^VADPT
"RTN","IBNCPDPU",361,0)
I $P($G(VAEL(6)),"^",2)'="ACTIVE DUTY" Q 0
"RTN","IBNCPDPU",362,0)
; If the PERIOD OF SERVICE has '-ACTIVE DUTY', quit with true
"RTN","IBNCPDPU",363,0)
I $F($P($G(VAEL(2)),"^",2),"-ACTIVE DUTY") Q 1
"RTN","IBNCPDPU",364,0)
Q 0
"RTN","IBNCPDPU",365,0)
;
"RTN","IBNCPDPU",366,0)
;IBNCPDPU
"RTN","IBNCPDR4")
0^6^B37656873
"RTN","IBNCPDR4",1,0)
IBNCPDR4 ;ALB/BDB - ROI MANAGEMENT, ROI CHECK ;30-NOV-07
"RTN","IBNCPDR4",2,0)
;;2.0;INTEGRATED BILLING;**384,550,624**;21-MAR-94;Build 8
"RTN","IBNCPDR4",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBNCPDR4",4,0)
;
"RTN","IBNCPDR4",5,0)
;
"RTN","IBNCPDR4",6,0)
ROICHK(IBPAT,IBDRUG,IBINS,IBDT) ;Check for ROI
"RTN","IBNCPDR4",7,0)
;Function returns:
"RTN","IBNCPDR4",8,0)
; 0 - if no ROI on file
"RTN","IBNCPDR4",9,0)
; 1 - if ROI on file, new ROI added, or Date of Service is on or after the Mission
"RTN","IBNCPDR4",10,0)
; Act Implementation Date
"RTN","IBNCPDR4",11,0)
; 2 - if not needed, passes checks
"RTN","IBNCPDR4",12,0)
;
"RTN","IBNCPDR4",13,0)
; -- input IBPAT = patient (req)
"RTN","IBNCPDR4",14,0)
; IBDRUG = drug (req)
"RTN","IBNCPDR4",15,0)
; IBINS = insurance file 36 (req)
"RTN","IBNCPDR4",16,0)
; IBDT = fileman format fill date (req)
"RTN","IBNCPDR4",17,0)
N DIC,DIE,DA,DR,DQ,D0,DI,D,X,Y
"RTN","IBNCPDR4",18,0)
I $$ROI(IBPAT,IBDRUG,IBINS,IBDT) Q 1 ;ROI is on file
"RTN","IBNCPDR4",19,0)
K ^TMP($J,"IBDRUG")
"RTN","IBNCPDR4",20,0)
D DATA^PSS50(IBDRUG,,,,,"IBDRUG")
"RTN","IBNCPDR4",21,0)
I '$$SENS^IBNCPDR(IBDRUG) Q 2 ; drug not sensitive, ROI not needed
"RTN","IBNCPDR4",22,0)
; Check to see if the Date of Service (DOS) is prior to the Mission Act Implementation Date
"RTN","IBNCPDR4",23,0)
; If the DOS is on or after the Mission Act Date don't perform ROI checks
"RTN","IBNCPDR4",24,0)
I $$MACHK^IBNCPDR4(IBDT) Q 1
"RTN","IBNCPDR4",25,0)
;
"RTN","IBNCPDR4",26,0)
D EN^DDIOL("This drug requires a Release of Information(ROI) for:","","!!")
"RTN","IBNCPDR4",27,0)
D EN^DDIOL(" PATIENT: ","","!") D EN^DDIOL($E($P($G(^DPT(IBPAT,0)),U),1,20),"","?0")
"RTN","IBNCPDR4",28,0)
D EN^DDIOL(" DRUG: ","","!") D EN^DDIOL($E($G(^TMP($J,"IBDRUG",IBDRUG,.01)),1,30),"","?0")
"RTN","IBNCPDR4",29,0)
D EN^DDIOL(" INSURANCE COMPANY: ","","!") D EN^DDIOL($P($G(^DIC(36,+IBINS,0)),U),"","?0")
"RTN","IBNCPDR4",30,0)
D EN^DDIOL(" FILL DATE: ","","!") D EN^DDIOL($$DAT1^IBOUTL(IBDT),"","?0")
"RTN","IBNCPDR4",31,0)
I '$$KCHK^XUSRB("IBCNR ROI") Q 0
"RTN","IBNCPDR4",32,0)
K ^TMP($J,"IBDRUG")
"RTN","IBNCPDR4",33,0)
S DIR(0)="Y",DIR("A")="Do you want to add a new ROI for this patient? "
"RTN","IBNCPDR4",34,0)
S DIR("B")="NO"
"RTN","IBNCPDR4",35,0)
S DIR("?")="If you want to add a new ROI, enter 'Yes' - otherwise, enter 'No'"
"RTN","IBNCPDR4",36,0)
D EN^DDIOL("","","!") D ^DIR K DIR
"RTN","IBNCPDR4",37,0)
I 'Y D EN^DDIOL(" *** Rx requires an ROI. Please add the required ROI.","","!") Q 0 ;Stop processing
"RTN","IBNCPDR4",38,0)
I '$$AD(IBPAT,IBDRUG,IBINS,IBDT) D EN^DDIOL(" *** Rx requires an ROI.","","!") D EN^DDIOL(" Please add an ROI before submitting the claim.","","!") Q 0 ;Stop processing
"RTN","IBNCPDR4",39,0)
Q 1 ;Continue processing
"RTN","IBNCPDR4",40,0)
;
"RTN","IBNCPDR4",41,0)
ROICLN(IBTRN,IBRX,IBFIL) ;Clean NB reason, set CT ROI flag to 'obtained'
"RTN","IBNCPDR4",42,0)
; Clean ROI non-billable reason on Claims Tracking 356
"RTN","IBNCPDR4",43,0)
;
"RTN","IBNCPDR4",44,0)
; -- input IBTRN = IEN of Claims Tracking #356
"RTN","IBNCPDR4",45,0)
; IBRX = Rx IEN
"RTN","IBNCPDR4",46,0)
; IBFIL = RX fill number
"RTN","IBNCPDR4",47,0)
N DIE,DA,DR
"RTN","IBNCPDR4",48,0)
I '$G(IBTRN) S IBTRN=+$O(^IBT(356,"ARXFL",$G(IBRX),$G(IBFIL),0))
"RTN","IBNCPDR4",49,0)
I IBTRN D
"RTN","IBNCPDR4",50,0)
. S DR=".31////2" ; set CT ROI flag to 'obtained'
"RTN","IBNCPDR4",51,0)
. ;
"RTN","IBNCPDR4",52,0)
. ; If the current RNB contains "ROI", then clear it out - IB*2*550
"RTN","IBNCPDR4",53,0)
. I $P($G(^IBE(356.8,+$P($G(^IBT(356,IBTRN,0)),U,19),0)),U,1)["ROI" S DR=DR_";.19///@"
"RTN","IBNCPDR4",54,0)
. S DIE="^IBT(356,",DA=IBTRN D ^DIE ;clean NB reason
"RTN","IBNCPDR4",55,0)
Q
"RTN","IBNCPDR4",56,0)
;
"RTN","IBNCPDR4",57,0)
;Check for Release of Information (ROI) on file
"RTN","IBNCPDR4",58,0)
ROI(IBDFN,IBDRUG,IBINS,IBADT) ; -- Check for ROI on file
"RTN","IBNCPDR4",59,0)
; Function returns:
"RTN","IBNCPDR4",60,0)
; 1 = if ROI on file or Date of Service is on or after Mission Act Implementation Date
"RTN","IBNCPDR4",61,0)
; 0 = if no ROI on file
"RTN","IBNCPDR4",62,0)
;
"RTN","IBNCPDR4",63,0)
; -- input IBDFN = patient (req)
"RTN","IBNCPDR4",64,0)
; IBDRUG = drug (req)
"RTN","IBNCPDR4",65,0)
; IBINS = insurance file 36 (req)
"RTN","IBNCPDR4",66,0)
; IBADT = fileman format fill date (req)
"RTN","IBNCPDR4",67,0)
;
"RTN","IBNCPDR4",68,0)
N IBROI,IBFLG
"RTN","IBNCPDR4",69,0)
S IBFLG=0 ;No ROI on file
"RTN","IBNCPDR4",70,0)
; Check to see if the Date of Service (DOS) is prior to the Mission Act Implementation Date.
"RTN","IBNCPDR4",71,0)
; If the DOS is on or after the Mission Act Date don't perform ROI checks.
"RTN","IBNCPDR4",72,0)
I $$MACHK^IBNCPDR4(IBADT) S IBFLG=1 G ROIQ
"RTN","IBNCPDR4",73,0)
;
"RTN","IBNCPDR4",74,0)
;Check for ROI on file
"RTN","IBNCPDR4",75,0)
S IBROI=0 F S IBROI=$O(^IBT(356.25,"AC",IBDFN,IBDRUG,IBINS,IBROI)) G:'IBROI ROIQ D G:IBFLG ROIQ
"RTN","IBNCPDR4",76,0)
. I IBADT<$P(^IBT(356.25,IBROI,0),U,5)!(IBADT>$P(^IBT(356.25,IBROI,0),U,6)) Q ;Date out of range
"RTN","IBNCPDR4",77,0)
. I $P(^IBT(356.25,IBROI,0),U,7)="0" Q ;Inactive ROI
"RTN","IBNCPDR4",78,0)
. S IBFLG=1 ;ROI on file
"RTN","IBNCPDR4",79,0)
. S DIE="^IBT(356.25,",DA=IBROI,DR="1.05///NOW" D ^DIE
"RTN","IBNCPDR4",80,0)
ROIQ ;
"RTN","IBNCPDR4",81,0)
Q IBFLG
"RTN","IBNCPDR4",82,0)
;
"RTN","IBNCPDR4",83,0)
AD(IBDFN,IBDRUG,IBINS,IBDT) ; -- Add tracking entry
"RTN","IBNCPDR4",84,0)
; Function returns 1 if ROI added, 0 if not added
"RTN","IBNCPDR4",85,0)
N X,Y,DIC,DIR,DA,DR,DTOUT,DUOUT,IBQUIT,IBEFFDT,IBEXPDT
"RTN","IBNCPDR4",86,0)
S IBQUIT=0
"RTN","IBNCPDR4",87,0)
F S DIR("?")="The ROI effective date must be prior to or equal to the fill date.",DIR("A")="Enter the ROI effective date for the ROI: ",DIR(0)="DATE" D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT) D Q:IBQUIT
"RTN","IBNCPDR4",88,0)
. S X=Y,%DT="E" D ^%DT I Y<0 D EN^DDIOL("Must enter a valid date","","!") Q
"RTN","IBNCPDR4",89,0)
. I Y>IBDT D EN^DDIOL("The ROI effective date must be prior to or equal to the fill date.","","!") Q
"RTN","IBNCPDR4",90,0)
. S IBEFFDT=Y,IBQUIT=1 Q
"RTN","IBNCPDR4",91,0)
G:'IBQUIT ADDQ
"RTN","IBNCPDR4",92,0)
S IBQUIT=0
"RTN","IBNCPDR4",93,0)
F S DIR("?")="The ROI expiration date must be equal to or after the fill date.",DIR("A")="Enter the ROI expiration date for the ROI: ",DIR(0)="DATE" D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT) D Q:IBQUIT
"RTN","IBNCPDR4",94,0)
. S X=Y,%DT="E" D ^%DT I Y<0 D EN^DDIOL("Must enter a valid date","","!") Q
"RTN","IBNCPDR4",95,0)
. I Y<IBDT D EN^DDIOL("The ROI expiration date must be equal to or after the fill date.","","!") Q
"RTN","IBNCPDR4",96,0)
. S IBEXPDT=Y,IBQUIT=1 Q
"RTN","IBNCPDR4",97,0)
G:'IBQUIT ADDQ
"RTN","IBNCPDR4",98,0)
L +^IBT(356.25,0):10 I '$T D PAUSE^IBNCPBB("ROI File busy while trying to add a new entry") S IBQUIT=0 G ADDQ
"RTN","IBNCPDR4",99,0)
S X=$P($S($D(^IBT(356.25,0)):^(0),1:"^^-1"),"^",3)+1 L -^IBT(356.25,0)
"RTN","IBNCPDR4",100,0)
S DIC="^IBT(356.25,",DIC(0)="L",DLAYGO=356.25,DIC("DR")=".02////"_IBDFN_";.03////"_IBDRUG_";.04////"_IBINS_";.05///"_IBEFFDT_";.06////"_IBEXPDT_";.07////1;1.01///NOW;1.02////"_DUZ_";1.03///NOW;1.04////"_DUZ_";1.05///NOW;2.01" D FILE^DICN
"RTN","IBNCPDR4",101,0)
I Y<1!($D(DUOUT))!($D(DTOUT)) S IBQUIT=0 G ADDQ
"RTN","IBNCPDR4",102,0)
N IBNCRPR I +Y>0 S IBNCRPR=+Y,ZTIO="",ZTRTN="CTCLN^IBNCPDR2",ZTDTH=$H,ZTSAVE("IBNCRPR")="",ZTDESC="IB - Make ROI Pharmacy entries in Claims Tracking billable"
"RTN","IBNCPDR4",103,0)
D ^%ZTLOAD K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
"RTN","IBNCPDR4",104,0)
ADDQ Q IBQUIT
"RTN","IBNCPDR4",105,0)
;
"RTN","IBNCPDR4",106,0)
;Check for ROI on file
"RTN","IBNCPDR4",107,0)
ROI399(IBIFN) ; -- ROI Complete? in Bill/Claims (#399;157)
"RTN","IBNCPDR4",108,0)
; Check drugs that contain the sensitive diagnosis drug field=1,
"RTN","IBNCPDR4",109,0)
; Claims Tracking ROI file (#356.25) to see if an ROI is on file
"RTN","IBNCPDR4",110,0)
;
"RTN","IBNCPDR4",111,0)
; input - IBIFN = IEN of the Bill/Claims file (#399)
"RTN","IBNCPDR4",112,0)
; output - 0 = sensitive diagnosis drug and no ROI on file
"RTN","IBNCPDR4",113,0)
; 1 = default, sensitive diagnosis drug and ROI on file, or if the
"RTN","IBNCPDR4",114,0)
; Date of Service (DOS) is on or after Mission Act Implementation Date
"RTN","IBNCPDR4",115,0)
N IBX,IBY0,IBRXIEN,IBDT,IBDRUG,ROIQ,IBDFN,IBINS
"RTN","IBNCPDR4",116,0)
N DIC,DIE,DA,DR,DQ,D0,DI,DISYS,D,X,Y,DE,DW,DV,DL,DLB
"RTN","IBNCPDR4",117,0)
S IBDFN=$P(^DGCR(399,IBIFN,0),U,2) ;patient
"RTN","IBNCPDR4",118,0)
S IBINS=$P(^DGCR(399,IBIFN,"MP"),U,1) ;payer insurance company
"RTN","IBNCPDR4",119,0)
I 'IBINS S ROIQ=1 G ROI399Q
"RTN","IBNCPDR4",120,0)
S ROIQ=1
"RTN","IBNCPDR4",121,0)
S IBX=0 F S IBX=$O(^IBA(362.4,"C",$G(IBIFN),$G(IBX))) Q:'IBX D
"RTN","IBNCPDR4",122,0)
.S IBY0=^IBA(362.4,IBX,0),IBRXIEN=$P(IBY0,U,5) I 'IBRXIEN Q
"RTN","IBNCPDR4",123,0)
.S IBDT=$P(IBY0,U,3),IBDRUG=$P(IBY0,U,4)
"RTN","IBNCPDR4",124,0)
.K ^TMP($J,"IBDRUG") D ZERO^IBRXUTL(IBDRUG)
"RTN","IBNCPDR4",125,0)
.I $$SENS^IBNCPDR(IBDRUG) D
"RTN","IBNCPDR4",126,0)
.. ; If DOS is on or after the Mission Act Implementation Date, don't perform ROI checks
"RTN","IBNCPDR4",127,0)
.. I $$MACHK^IBNCPDR4(IBDT) Q
"RTN","IBNCPDR4",128,0)
.. I $$ROICHK^IBNCPDR4(IBDFN,IBDRUG,IBINS,IBDT) Q
"RTN","IBNCPDR4",129,0)
.. S ROIQ=0
"RTN","IBNCPDR4",130,0)
ROI399Q ;
"RTN","IBNCPDR4",131,0)
Q ROIQ
"RTN","IBNCPDR4",132,0)
;
"RTN","IBNCPDR4",133,0)
;Check to see if Date of Service (DOS) is prior to Mission Act
"RTN","IBNCPDR4",134,0)
; Implementation Date (MAID)
"RTN","IBNCPDR4",135,0)
;If the Rx is released, the DOS will be the Released Date otherwise the DOS is today.
"RTN","IBNCPDR4",136,0)
;
"RTN","IBNCPDR4",137,0)
; input - IBDOS = Date of Service (DOS)
"RTN","IBNCPDR4",138,0)
; output - 0 = if DOS is prior to MAID, check ROI
"RTN","IBNCPDR4",139,0)
; 1 = if DOS is on or after MAID, don't check ROI
"RTN","IBNCPDR4",140,0)
;
"RTN","IBNCPDR4",141,0)
MACHK(IBDOS) ;
"RTN","IBNCPDR4",142,0)
N IBMAID,IBROI
"RTN","IBNCPDR4",143,0)
S IBROI=1
"RTN","IBNCPDR4",144,0)
I 'IBDOS S IBROI=0 Q IBROI
"RTN","IBNCPDR4",145,0)
;Checks to see if the Date of Service is prior to the Mission Act Implementation Date
"RTN","IBNCPDR4",146,0)
S IBMAID=3190128
"RTN","IBNCPDR4",147,0)
I IBDOS<IBMAID S IBROI=0
"RTN","IBNCPDR4",148,0)
Q IBROI
"RTN","IBTRKR3")
0^7^B59891059
"RTN","IBTRKR3",1,0)
IBTRKR3 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK RX FILLS ;13-AUG-93
"RTN","IBTRKR3",2,0)
;;2.0;INTEGRATED BILLING;**13,43,121,160,247,275,260,309,336,312,339,347,405,384,550,624**;21-MAR-94;Build 8
"RTN","IBTRKR3",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBTRKR3",4,0)
;
"RTN","IBTRKR3",5,0)
% ; -- entry point for nightly background job
"RTN","IBTRKR3",6,0)
N IBTSBDT,IBTSEDT
"RTN","IBTRKR3",7,0)
S IBTSBDT=$$FMADD^XLFDT(DT,-14)-.1
"RTN","IBTRKR3",8,0)
S IBTSEDT=$$FMADD^XLFDT(DT,-7)+.9
"RTN","IBTRKR3",9,0)
D EN1
"RTN","IBTRKR3",10,0)
Q
"RTN","IBTRKR3",11,0)
;
"RTN","IBTRKR3",12,0)
EN ; -- entry point to ask date range
"RTN","IBTRKR3",13,0)
N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
"RTN","IBTRKR3",14,0)
N IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK,IBMESS
"RTN","IBTRKR3",15,0)
S IBTALK=1
"RTN","IBTRKR3",16,0)
I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prescription Refills is currently turned off." G ENQ
"RTN","IBTRKR3",17,0)
W !!!,"Select the Date Range of Rx Refills to Add to Claims Tracking.",!
"RTN","IBTRKR3",18,0)
D DATE^IBOUTL
"RTN","IBTRKR3",19,0)
I IBBDT<1!(IBEDT<1) G ENQ
"RTN","IBTRKR3",20,0)
S IBTSBDT=IBBDT,IBTSEDT=IBEDT
"RTN","IBTRKR3",21,0)
;
"RTN","IBTRKR3",22,0)
; Do NOT PROCESS on VistA if Start or End>=Switch Eff Date ;IB*2.0*312
"RTN","IBTRKR3",23,0)
I +IBSWINFO,((IBTSBDT+1)>$P(IBSWINFO,"^",2))!((IBTSEDT+1)>$P(IBSWINFO,"^",2)) D G EN
"RTN","IBTRKR3",24,0)
.W !!,"The Begin OR End Date CANNOT be on or after"
"RTN","IBTRKR3",25,0)
.W !,"the PFSS Effective Date: ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
"RTN","IBTRKR3",26,0)
;
"RTN","IBTRKR3",27,0)
; -- check selected dates
"RTN","IBTRKR3",28,0)
S IBTRKR=$G(^IBE(350.9,1,6))
"RTN","IBTRKR3",29,0)
; start date can't be before parameters
"RTN","IBTRKR3",30,0)
I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR W !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT)
"RTN","IBTRKR3",31,0)
; -- end date into future
"RTN","IBTRKR3",32,0)
I IBTSEDT>$$FMADD^XLFDT(DT,-3) W !!,"I'll automatically change the end date to 3 days prior to the date queued to run."
"RTN","IBTRKR3",33,0)
;
"RTN","IBTRKR3",34,0)
W !!!,"I'm going to automatically queue this off and send you a"
"RTN","IBTRKR3",35,0)
W !,"mail message when complete.",!
"RTN","IBTRKR3",36,0)
S ZTIO="",ZTRTN="EN1^IBTRKR3",ZTSAVE("IB*")="",ZTDESC="IB - Add Rx Refills to Claims Tracking"
"RTN","IBTRKR3",37,0)
D ^%ZTLOAD I $G(ZTSK) K ZTSK W !,"Request Queued"
"RTN","IBTRKR3",38,0)
ENQ K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
"RTN","IBTRKR3",39,0)
D HOME^%ZIS
"RTN","IBTRKR3",40,0)
Q
"RTN","IBTRKR3",41,0)
;
"RTN","IBTRKR3",42,0)
EN1 ; -- add rx refills to claims tracking file
"RTN","IBTRKR3",43,0)
N I,J,X,Y,IBTRKR,IBDT,IBRXN,IBFILL,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,LIST1
"RTN","IBTRKR3",44,0)
N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
"RTN","IBTRKR3",45,0)
N IBICD,IBCOPAY
"RTN","IBTRKR3",46,0)
;
"RTN","IBTRKR3",47,0)
; -- check parameters
"RTN","IBTRKR3",48,0)
S IBTRKR=$G(^IBE(350.9,1,6))
"RTN","IBTRKR3",49,0)
G:'$P(IBTRKR,"^",4) EN1Q ; quit if rx tracking off
"RTN","IBTRKR3",50,0)
I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR ; start date can't be before parameters
"RTN","IBTRKR3",51,0)
;
"RTN","IBTRKR3",52,0)
; -- users can queue into future, make sure dates not after date run
"RTN","IBTRKR3",53,0)
I IBTSEDT>$$FMADD^XLFDT(DT,-3) S IBMESS="(Selected end date of "_$$DAT1^IBOUTL(IBTSEDT)_" automatically changed to "_$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-3))_".)",IBTSEDT=$$FMADD^XLFDT(DT,-3)
"RTN","IBTRKR3",54,0)
;
"RTN","IBTRKR3",55,0)
S IBRXTYP=$O(^IBE(356.6,"AC",4,0)) ; event type pointer for rx billing
"RTN","IBTRKR3",56,0)
;
"RTN","IBTRKR3",57,0)
; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
"RTN","IBTRKR3",58,0)
S (IBCNT,IBCNT1,IBCNT2)=0
"RTN","IBTRKR3",59,0)
S IBDT=IBTSBDT-.0001
"RTN","IBTRKR3",60,0)
S LIST1="IBTRKAD"
"RTN","IBTRKR3",61,0)
D REF^PSO52EX(IBDT,IBTSEDT,LIST1)
"RTN","IBTRKR3",62,0)
S IBDT=0
"RTN","IBTRKR3",63,0)
F S IBDT=$O(^TMP($J,LIST1,"AD",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D
"RTN","IBTRKR3",64,0)
.S IBRXN=0
"RTN","IBTRKR3",65,0)
.I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q
"RTN","IBTRKR3",66,0)
.F S IBRXN=$O(^TMP($J,LIST1,"AD",IBDT,IBRXN)) Q:'IBRXN D
"RTN","IBTRKR3",67,0)
..S IBFILL=""
"RTN","IBTRKR3",68,0)
..F S IBFILL=$O(^TMP($J,LIST1,"AD",IBDT,IBRXN,IBFILL)) Q:IBFILL="" D RXCHK
"RTN","IBTRKR3",69,0)
K ^TMP($J,LIST1)
"RTN","IBTRKR3",70,0)
;
"RTN","IBTRKR3",71,0)
I $G(IBTALK) D BULL^IBTRKR31
"RTN","IBTRKR3",72,0)
EN1Q I $D(ZTQUEUED) S ZTREQ="@"
"RTN","IBTRKR3",73,0)
Q
"RTN","IBTRKR3",74,0)
;
"RTN","IBTRKR3",75,0)
RXCHK ; -- check and add rx
"RTN","IBTRKR3",76,0)
N IBND,LIST,NODE
"RTN","IBTRKR3",77,0)
S IBCNT=IBCNT+1
"RTN","IBTRKR3",78,0)
;I IBFILL<1 G RXCHKQ ; original fill
"RTN","IBTRKR3",79,0)
I IBDT>(DT+.24) G RXCHKQ ; future fill
"RTN","IBTRKR3",80,0)
I '$D(ZTQUEUED),($G(IBTALK)) W "."
"RTN","IBTRKR3",81,0)
;
"RTN","IBTRKR3",82,0)
S DFN=$$FILE^IBRXUTL(IBRXN,2)
"RTN","IBTRKR3",83,0)
S IBRXDATA=$$RXZERO^IBRXUTL(DFN,IBRXN),IBRXSTAT=$$FILE^IBRXUTL(IBRXN,100,"I")
"RTN","IBTRKR3",84,0)
;I IBDT=$P($O(^DPT(DFN,"S",(IBDT-.00001))),".") G RXCHKQ ;scheduled appointment on same day as fill date
"RTN","IBTRKR3",85,0)
;I $$BABCSC^IBEFUNC(DFN,$P(IBDT,".",1)) G RXCHKQ ; is billable clinic stop in encounter file for data (allows telephone stops on same day, but not others) (P121 - RC, can now bill Rx if on same day as opt visit)
"RTN","IBTRKR3",86,0)
;
"RTN","IBTRKR3",87,0)
; -- not already in claims tracking
"RTN","IBTRKR3",88,0)
I $O(^IBT(356,"ARXFL",IBRXN,IBFILL,"")) G RXCHKQ ; already in claims tracking
"RTN","IBTRKR3",89,0)
;
"RTN","IBTRKR3",90,0)
; -- see if tracking only insured and pt is insured
"RTN","IBTRKR3",91,0)
I $P(IBTRKR,"^",4)=1,'$$INSURED^IBCNS1(DFN,IBDT) G RXCHKQ ; patient not insure
"RTN","IBTRKR3",92,0)
;
"RTN","IBTRKR3",93,0)
; -- check rx status (not deleted)
"RTN","IBTRKR3",94,0)
I IBRXSTAT=13 G RXCHKQ
"RTN","IBTRKR3",95,0)
;
"RTN","IBTRKR3",96,0)
; -- Don't PROCESS IF there is already a PFSS ACCT REF# -- ;IB*2.0*312
"RTN","IBTRKR3",97,0)
I 'IBFILL,+$$FILE^IBRXUTL(IBRXN,125) G RXCHKQ
"RTN","IBTRKR3",98,0)
I +IBFILL,+$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,21) G RXCHKQ
"RTN","IBTRKR3",99,0)
;
"RTN","IBTRKR3",100,0)
; -- original fill not released or returned to stock
"RTN","IBTRKR3",101,0)
I 'IBFILL,'$$FILE^IBRXUTL(IBRXN,31) G RXCHKQ
"RTN","IBTRKR3",102,0)
I 'IBFILL,$$FILE^IBRXUTL(IBRXN,32.1) G RXCHKQ
"RTN","IBTRKR3",103,0)
;
"RTN","IBTRKR3",104,0)
; -- refill not released or returned to stock
"RTN","IBTRKR3",105,0)
I +IBFILL,'$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,17) G RXCHKQ
"RTN","IBTRKR3",106,0)
I +IBFILL,$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,14) G RXCHKQ
"RTN","IBTRKR3",107,0)
;
"RTN","IBTRKR3",108,0)
; -- check drug (not investigational, supply, over the counter drug, or nutritional supplement
"RTN","IBTRKR3",109,0)
S IBDRUG=$P(IBRXDATA,"^",6)
"RTN","IBTRKR3",110,0)
D ZERO^IBRXUTL(IBDRUG)
"RTN","IBTRKR3",111,0)
S IBDEA=$G(^TMP($J,"IBDRUG",+IBDRUG,3))
"RTN","IBTRKR3",112,0)
K ^TMP($J,"IBDRUG")
"RTN","IBTRKR3",113,0)
I IBDEA["I"!(IBDEA["S")!(IBDEA["9")!(IBDEA["N") G RXCHKQ ; investigational drug, supply, otc, or nutritional supplement
"RTN","IBTRKR3",114,0)
;
"RTN","IBTRKR3",115,0)
; -- see if insured for prescriptions
"RTN","IBTRKR3",116,0)
I '$$PTCOV^IBCNSU3(DFN,IBDT,"PHARMACY",.IBANY) S IBRMARK=$S($G(IBANY):"NO PHARMACY COVERAGE",1:"NOT INSURED")
"RTN","IBTRKR3",117,0)
;
"RTN","IBTRKR3",118,0)
; -- check sc status and others
"RTN","IBTRKR3",119,0)
; -- new ICD node in PSO with CIDC, if it exists use this for determination
"RTN","IBTRKR3",120,0)
S LIST="IBTRKRLST"
"RTN","IBTRKR3",121,0)
S NODE="ICD"
"RTN","IBTRKR3",122,0)
S IBICD=0,IBCOPAY=0
"RTN","IBTRKR3",123,0)
D RX^PSO52API(DFN,LIST,IBRXN,,NODE,,)
"RTN","IBTRKR3",124,0)
I +$G(^TMP($J,LIST,DFN,IBRXN,"ICD",0))>0 S IBICD=1 ;Setup ICD Flag
"RTN","IBTRKR3",125,0)
I +$$IBND^IBRXUTL(DFN,IBRXN)>0 S IBCOPAY=1 ;Setup Copay Flag
"RTN","IBTRKR3",126,0)
I $G(IBRMARK)="",IBICD D CL^SDCO21(DFN,IBDT,"",.IBARR) I $D(IBARR) D
"RTN","IBTRKR3",127,0)
.S IBM=0
"RTN","IBTRKR3",128,0)
.F S IBM=$O(^TMP($J,LIST,DFN,IBRXN,"ICD",IBM)) Q:'IBM!($G(IBRMARK)'="") D
"RTN","IBTRKR3",129,0)
..S IBZ=$$ICD^IBRXUTL1(DFN,IBRXN,IBM,LIST) F IBP=1:1:7 Q:$G(IBRMARK)'="" I $D(IBARR(IBP)) D
"RTN","IBTRKR3",130,0)
... S IBRMARK=$S($P(IBZ,"^",IBP+1):$P($T(EXEMPT+IBP),";",3),$P(IBZ,"^",IBP+1)=0:"",1:"NEEDS SC DETERMINATION")
"RTN","IBTRKR3",131,0)
;
"RTN","IBTRKR3",132,0)
; -- no new ICD node in PSO, use old method of determining status
"RTN","IBTRKR3",133,0)
I $G(IBRMARK)="",'IBICD D
"RTN","IBTRKR3",134,0)
. D ELIG^VADPT
"RTN","IBTRKR3",135,0)
. ;if the patient is covered by insurance for pharmacy ($G(IBRMARK)="")
"RTN","IBTRKR3",136,0)
. ;AND if no copay in #350
"RTN","IBTRKR3",137,0)
. ;then we need to determine the non billable reason and set IBRMARK
"RTN","IBTRKR3",138,0)
. ;
"RTN","IBTRKR3",139,0)
. ;IF VAEL(3) -- if this is a veteran with SC(service connection) status
"RTN","IBTRKR3",140,0)
. I VAEL(3),'IBCOPAY D
"RTN","IBTRKR3",141,0)
. . I $P(VAEL(3),"^",2)>49 S IBRMARK="NEEDS SC DETERMINATION"
"RTN","IBTRKR3",142,0)
. . ;in case of POW and Unempl.vet we cannot decide if the 3rd party should be exempt
"RTN","IBTRKR3",143,0)
. . N IBPOWUNV,IBAUTRET S IBAUTRET=$$AUTOINFO^DGMTCOU1(DFN),IBPOWUNV=$S($P(IBAUTRET,U,8):1,$P(IBAUTRET,U,9):1,1:0)
"RTN","IBTRKR3",144,0)
. . I $P(VAEL(3),"^",2)<50 S IBRMARK=$S(IBPOWUNV:"NEEDS SC DETERMINATION",1:"SC TREATMENT")
"RTN","IBTRKR3",145,0)
. . I $$RXST^IBARXEU(DFN,$P(IBRXDATA,U,13))>0 S IBRMARK="NEEDS SC DETERMINATION"
"RTN","IBTRKR3",146,0)
. ;
"RTN","IBTRKR3",147,0)
. ;IF +VAEL(3)=0 if the veteran doesn't have SC status, but
"RTN","IBTRKR3",148,0)
. ;the veteran still may have CV status active
"RTN","IBTRKR3",149,0)
. I $G(IBRMARK)="",+VAEL(3)=0,'IBCOPAY D
"RTN","IBTRKR3",150,0)
. . I $$CVEDT^IBACV(DFN,IBDT) S IBRMARK="NEEDS SC DETERMINATION" ;SC-because IB staff usually is using this reason to search for cases that need to be reviewed. COMBAT VETERAN reason will be used after review if this was a case
"RTN","IBTRKR3",151,0)
;
"RTN","IBTRKR3",152,0)
K ^TMP($J,LIST)
"RTN","IBTRKR3",153,0)
;
"RTN","IBTRKR3",154,0)
; ROI check. The variable IBSCROI will be set to:
"RTN","IBTRKR3",155,0)
; '1' if NOT REQUIRED '2' if OBTAINED
"RTN","IBTRKR3",156,0)
; '3' if REQUIRED '4' if REFUSED
"RTN","IBTRKR3",157,0)
N IBSCROI
"RTN","IBTRKR3",158,0)
;
"RTN","IBTRKR3",159,0)
; $$SENS^IBNCPDR returns 1 if the drug is sensitive diagnosis drug
"RTN","IBTRKR3",160,0)
;
"RTN","IBTRKR3",161,0)
I $$SENS^IBNCPDR(IBDRUG) D
"RTN","IBTRKR3",162,0)
. N IBINS,IBFLG,IBINSP
"RTN","IBTRKR3",163,0)
. D ALL^IBCNS1(DFN,"IBINS",1,IBDT,1)
"RTN","IBTRKR3",164,0)
. S IBINSP=$O(IBINS("S",1,99),-1) Q:IBINSP=""
"RTN","IBTRKR3",165,0)
. ;Check to see if the Date of Service (DOS) is on or after to the Mission Act Implementation
"RTN","IBTRKR3",166,0)
. ; Date (MAID). $$MACHK^IBNCPDR4 returns 1 if the DOS is on or after MAID. If 1 is returned
"RTN","IBTRKR3",167,0)
. ; set (IBFLG,IBSCROI=1 and IBRMARK="" (file 356,#.19 NON-BILLABLE REASON)
"RTN","IBTRKR3",168,0)
. I $$MACHK^IBNCPDR4(IBDT) S (IBFLG,IBSCROI)=1,IBRMARK="" Q
"RTN","IBTRKR3",169,0)
. S IBFLG=$$ROI^IBNCPDR4(DFN,$G(IBDRUG),+$G(IBINS(IBINSP,"0")),$G(IBDT))
"RTN","IBTRKR3",170,0)
. I 'IBFLG,$G(IBRMARK)="" S IBRMARK="ROI NOT OBTAINED" ; IB*2*550
"RTN","IBTRKR3",171,0)
. I 'IBFLG S IBSCROI=3
"RTN","IBTRKR3",172,0)
. I IBFLG S IBSCROI=2
"RTN","IBTRKR3",173,0)
;
"RTN","IBTRKR3",174,0)
; -- ok to add to tracking module
"RTN","IBTRKR3",175,0)
D REFILL^IBTUTL1(DFN,IBRXTYP,IBDT,IBRXN,IBFILL,$G(IBRMARK),,$G(IBSCROI)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
"RTN","IBTRKR3",176,0)
;
"RTN","IBTRKR3",177,0)
I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1
"RTN","IBTRKR3",178,0)
I $G(IBRMARK)="" S IBCNT1=IBCNT1+1
"RTN","IBTRKR3",179,0)
K IBANY,IBRMARK,VAEL,VA,IBDEA,IBDRUG,IBRXSTAT,IBRXDATA,DFN,X,Y
"RTN","IBTRKR3",180,0)
K IBARR,IBM,IBZ,IBP
"RTN","IBTRKR3",181,0)
RXCHKQ Q
"RTN","IBTRKR3",182,0)
;
"RTN","IBTRKR3",183,0)
EXEMPT ; exemption reasons
"RTN","IBTRKR3",184,0)
;;AGENT ORANGE
"RTN","IBTRKR3",185,0)
;;IONIZING RADIATION
"RTN","IBTRKR3",186,0)
;;SC TREATMENT
"RTN","IBTRKR3",187,0)
;;SOUTHWEST ASIA
"RTN","IBTRKR3",188,0)
;;MILITARY SEXUAL TRAUMA
"RTN","IBTRKR3",189,0)
;;HEAD/NECK CANCER
"RTN","IBTRKR3",190,0)
;;COMBAT VETERAN
"RTN","IBTRKR3",191,0)
;;PROJECT 112/SHAD
"RTN","IBTRKR3",192,0)
;;
"VER")
8.0^22.2
**END**
**END**